Professions: pool extracted effect sizes (Creativity and Handedness)

[1] “Loading existing glm data table found at /home/om/proj/ch/analyses/professions/2_pool/data/proc/glm_data.csv”

Calculate pooled effect sizes for each profession

Pool estimates from studies with odds ratios for left or mixed handers between a creative and control group. Pool estimated odds ratios for each profession.

An odds ratio greater than 1 indicates lefty/mixedy advantage.

R/L + S/M

An odds ratio greater than one is a lefty/mixedy advantage.

From raw proportions, using metabin

All studies

From raw proportions, using metabin
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	17	9	0.91	1.042	1.193	.55	.20 [.00, .55]	random	GLMM	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.020999999999999), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.482000000000001), 4.2-0, UM.FS
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	Inverse	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, 1.05998403613453, 0.289151861978491, 0.95, -0.061642360556288, 0.20684541370225, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.05998403613453, 1.06369532430366, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, -0.061642360556288, 0.20684541370225, 1.05998403613453, 0.289151861978491, 1.05998403613453, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	MH	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 17, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, 0.589363980337228, 0.555617133864833, 0.95, -0.0940868567215518, 0.175002374312089, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.589363980337228, 1.06369532430366, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, -0.0940868567215518, 0.175002374312089, 0.589363980337228, 0.555617133864833, 0.589363980337228, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.815	1.065	1.393	.64	.40 [.00, .66]	random	Peto	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-1.43684210526316, -0.690261338333529, 1.00795306164762, 0.212037275367835, -0.358939974457216, -0.245902766320189, -0.103975776405053, -0.96814727649067, 2.71520154460688, 0.288825505247073, 0.0676634264671485, -0.0375389837855228, -1.15352537697584, -1.02389642850852, -1.24149907767122, -1.11687158278867, 0.510435812545122), c(1.56089219338149, 0.919851510749532, 0.295964545973394, 0.447210581153716, 0.4779292284239, 0.400819752502115, 0.39928626800966, 0.618795351373702, 1.39946633835025, 0.379240441958542, 0.171431799285525, 0.0929909160392439, 0.986041272695215, 2.27870185976276, 1.26445115535852, 1.63695215942607, 0.32406897670339), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), c(0.357297866196262, 0.453010712212803, 0.000660055934616421, 0.635405097974775, 0.452633611523925, 0.539546033178936, 0.794552090065137, 0.117684285849375, 0.052359125243574, 0.446305096005573, 0.693067336878847, 0.686444799637499, 0.242059299632813, 0.653191301938128, 0.326174643421658, 0.495057335302806, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -2.49313717052737, 0.427873210839015, -0.664479357198675, -1.29566404932708, -1.03149504551659, -0.886562481225394, -2.18096387898393, -0.0277020761357525, -0.454472102472721, -0.26833672593738, -0.219797830111829, -3.0861307587285, -5.49007000514796, -3.71977780238397, -4.32523885967883, -0.124727710300273), c(1.62245037751428, 1.11261449386031, 1.58803291245622, 1.08855390793435, 0.577784100412645, 0.539689512876215, 0.678610928415287, 0.244669326002593, 5.45810516534952, 1.03212311296687, 0.403663578871677, 0.144719862540783, 0.779080004776819, 3.44227714813093, 1.23677964704154, 2.09149569410149, 1.14559933539052), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, 0.592961663805544, 0.553206808576661, 0.95, -0.0951582454177123, 0.177711421329491, c(0.395391907150482, 1.06510043053455, 5.54487213854294, 3.41589434911937, 3.11363383013073, 3.94620110640505, 3.96540075258979, 2.10234428946293, 0.487505756565418, 4.22698736188081, 8.18728184765695, 9.86201973008252, 0.938941402440821, 0.189206382731604, 0.591160313115281, 0.360702973669442, 5.05631473520319), 0.0630490798536173, 0.13678244836612, 0.460944226446775, 0.644838620359311, classic, Inf, -0.205039592661188, 0.331137752368423, 0.13678244836612, , NA, 0.143767123196811, NA, NA, NA, HTS, , NA, 0.333858106594923, 15, 0.95, -0.648552629729578, 0.774650789436813, 0.143767123196811, 0.143767123196811, 26.4821853167165, 16, 0.047609917873651, REML, NULL, QP, 0.0927517971581165, 0.0891761562969764, 0, 1.08061331145796, 0.304551797167767, 0, 1.03952552227348, NULL, , , , 1.28652111614803, 1, 1.71725833898097, 0.395820253931225, 0, 0.660899264276656, 0.291616884234202, 0, 0.613097971938004, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0927517971581165, m4 = NULL), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), FALSE, 0.592961663805544, 0.460944226446775, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, -0.0951582454177123, 0.177711421329491, 0.592961663805544, 0.553206808576661, 0.592961663805544, Common effect model, common, NA, 0.143767123196811, NA, 1, FALSE, FALSE
OR	17	9	0.854	1.101	1.42	.46	.26 [.00, .59]	random	SSW	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, 1.20554350941747, 0.227993552034675, 0.95, -0.0602854100327486, 0.252954318616497, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.129638051538024, 0.743103225858177, 0.457419186766786, classic, Inf, -0.1577514577486, 0.350420366332349, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.20554350941747, 0.743103225858177, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, -0.0602854100327486, 0.252954318616497, 1.20554350941747, 0.227993552034675, 1.20554350941747, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
Art
OR	17	9	1.247	1.598	2.048	<.001	.59 [.30, .76]	random	GLMM	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999996), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.766), 4.2-0, UM.FS
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	Inverse	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 5.59787281727964, 2.16997844692742e-08, 0.95, 0.314512352102863, 0.653406431727379, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.59787281727964, 2.88818727880593, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 0.314512352102863, 0.653406431727379, 5.59787281727964, 2.16997844692742e-08, 5.59787281727964, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	MH	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 16, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 6.03879245958711, 1.55271798516199e-09, 0.95, 0.335531503617244, 0.657991576057912, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.03879245958711, 2.88818727880593, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 0.335531503617244, 0.657991576057912, 6.03879245958711, 1.55271798516199e-09, 6.03879245958711, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.152	1.596	2.212	.005	.65 [.42, .79]	random	Peto	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.37380660954712, 0.737734224795348, -0.12052903696899, -0.898720357210923, 2.88135593220339, 1.886625, 0.146763960036387, 0.190703412437214, -0.749367968408782, 0.0609904207495266, 0.313395219413491, 0.117134174635773, 0.510435812545122, 0.0562064185176206, 0.371336934921835, 0.213083622484386, 1.50046978291384), c(0.415528842183368, 0.342493017102583, 1.21687522422527, 0.876931092336367, 1.48876715444574, 0.673934343983151, 0.565457624206178, 0.294238027642615, 0.453165389135724, 1.04464964727608, 0.287580331760914, 0.372381982228678, 0.32406897670339, 0.475482940518229, 0.17013786477182, 0.286867912404376, 0.233931487850484), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), c(0.000945826213271411, 0.0312391951359797, 0.921100172165413, 0.305435300635845, 0.0529415602967437, 0.00511945666092442, 0.795211681566248, 0.51690324668251, 0.0982026747675452, 0.953443067420015, 0.275816308736864, 0.753100447472451, 0.115237090566695, 0.905901966336454, 0.0290678656470361, 0.457606707594208, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, 0.0664602463178242, -2.50556065012963, -2.61747371511357, -0.0365740718764318, 0.565737957848396, -0.961512618191306, -0.385992524624412, -1.63755581015488, -1.98648526437405, -0.250251873499981, -0.61272109902407, -0.124727710300273, -0.87572302016131, 0.0378728475625207, -0.349167154148383, 1.04197249187702), c(2.18822817476415, 1.40900820327287, 2.26450257619165, 0.820033000691724, 5.79928593628321, 3.2075120421516, 1.25504053826408, 0.767399349498841, 0.138819873337315, 2.10846610587311, 0.877042312326963, 0.846989448295615, 1.14559933539052, 0.988135857196551, 0.704801022281149, 0.775334399117154, 1.95896707395066), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 5.97515138157933, 2.29876620951754e-09, 0.95, 0.342256498088733, 0.676393036883093, c(2.34039020582257, 2.68877611668498, 0.576235936882886, 0.976922073540483, 0.404687479201077, 1.41083032215136, 1.74107655668937, 2.93090988293862, 2.17403673768121, 0.742992921004605, 2.96456685862538, 2.54269633016767, 2.78059189475238, 2.08030395739873, 3.52656747293488, 2.96816796823362, 3.23270045758165), 0.467416470190684, 0.166476130078398, 2.80770864850454, 0.00498953457085751, classic, Inf, 0.141129250951419, 0.793703689429949, 0.166476130078398, , NA, 0.174105471348229, NA, NA, NA, HTS, , NA, 0.531346647463955, 15, 0.95, -0.665122100081072, 1.59995504046244, 0.174105471348229, 0.174105471348229, 45.9739733189945, 16, 9.82687632317443e-05, REML, NULL, QP, 0.254614957885305, 0.153865974531026, 0.0732916386525852, 1.2351123835785, 0.504593854387174, 0.270724285302566, 1.11135610115683, NULL, , , , 1.695102749817, 1.31064081974728, 2.19234231770012, 0.651977002531789, 0.417853058300504, 0.791942552488268, 0.540419546756557, 0.298042011584244, 0.78279708192887, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.254614957885305, m4 = NULL), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), FALSE, 5.97515138157933, 2.80770864850454, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 0.342256498088733, 0.676393036883093, 5.97515138157933, 2.29876620951754e-09, 5.97515138157933, Common effect model, common, NA, 0.174105471348229, NA, 1, FALSE, FALSE
OR	17	9	1.156	1.624	2.279	.005	.61 [.33, .77]	random	SSW	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 4.45245214061084, 8.48951664069714e-06, 0.95, 0.271291286301498, 0.697950204760471, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.173122829486191, 2.79928849920766, 0.00512153558728871, classic, Inf, 0.145306234836381, 0.823935256225589, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 4.45245214061084, 2.79928849920766, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 0.271291286301498, 0.697950204760471, 4.45245214061084, 8.48951664069714e-06, 4.45245214061084, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
Music
OR	26	12	1.248	1.379	1.524	<.001	.03 [.00, .45]	random	GLMM	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.253), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.126), 4.2-0, UM.FS
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	Inverse	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 6.60558972822383, 3.95938005018008e-11, 0.95, 0.238851716327093, 0.440392170713961, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.60558972822383, 6.60513910530831, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 0.238851716327093, 0.440392170713961, 6.60558972822383, 3.95938005018008e-11, 6.60558972822383, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	MH	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 25, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 6.32363599960205, 2.55479143069901e-10, 0.95, 0.222522173794433, 0.422415953571305, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.32363599960205, 6.60513910530831, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 0.222522173794433, 0.422415953571305, 6.32363599960205, 2.55479143069901e-10, 6.32363599960205, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.2	1.367	1.558	<.001	.43 [.09, .64]	random	Peto	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, 1.17826257861635, -0.100526663026663, -0.301878909223286, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.490670728524915, 0.452618839163683, 0.441543762495517, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, -0.172032692354803, 0.516686677945751, 3.80987443815582, 1.10546580074985, -1.15406139984312, -1.02444480232342, -0.660637623336967, -1.11800549988975, 0.0562064185176206, 0.371336934921835), c(0.540780565579624, 1.32219331813667, 1.13845897443781, 0.417348609294271, 0.355932285189848, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 0.22726902886927, 0.244167347549023, 1.57151003840543, 0.663625553755456, 0.854369065122966, 1.97448261801463, 0.763018377649432, 0.988187320844407, 0.475482940518229, 0.17013786477182), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), c(0.10990091605911, 0.00351376944795559, 0.300686329135404, 0.809656053389246, 0.396362352687967, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.449076125152964, 0.0343348569588449, 0.0153362452313665, 0.0957537505474681, 0.176767133978651, 0.603870823550084, 0.386588123690052, 0.257899388302445, 0.905901966336454, 0.0290678656470361 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -1.05307600915816, -0.918514906241311, -0.999493369130427, 0.126119628474816, -0.109459222670617, 0.15271233326912, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, -0.617471803739965, 0.0381274705489931, 0.729771361538017, -0.195216383831291, -2.82859399698928, -4.89435962173246, -2.15612616307204, -3.05481705872391, -0.87572302016131, 0.0378728475625207 ), c(1.92442314671454, 6.45067458511826, 3.40960116639086, 0.717461580187986, 0.395735550683856, 0.761269452833273, 0.727504996658277, 0.801769440950646, 0.771661460016443, 0.820306387820303, 0.731535599651959, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 0.273406419030359, 0.995245885342509, 6.88997751477362, 2.406147985331, 0.520471197303052, 2.84547001708561, 0.834850916398102, 0.818806058944414, 0.988135857196551, 0.704801022281149), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 6.3335201530061, 2.39629990758453e-10, 0.95, 0.234363564503757, 0.444418781824495, c(3.2056225603369, 0.565705751325006, 0.760111130549942, 5.1629390927497, 6.8401297843006, 21.8520448228941, 15.3616893472612, 21.3107766402522, 24.9613969392452, 18.2809673841021, 24.1547311794734, 2.68568024987455, 3.296862573403, 10.7166459161808, 4.61263787309621, 3.25994543590123, 14.0529420991275, 12.6380775679207, 0.401743233696596, 2.17435197709279, 1.3343033465354, 0.255226406807943, 1.66194312120566, 1.00399343823993, 4.07178903620536, 20.6376378660032), 0.312794084274579, 0.0666281970608432, 4.69462026698612, 2.67102429424225e-06, classic, Inf, 0.182205217680489, 0.44338295086867, 0.0666281970608432, , NA, 0.0824475186200081, NA, NA, NA, HTS, , NA, 0.15475006120432, 24, 0.95, -0.00659434445686441, 0.632182513006023, 0.0824475186200081, 0.0824475186200081, 43.7272947845575, 25, 0.0116322939387831, REML, NULL, QP, 0.0195082647991621, 0.0243206297775738, 0.00956440915058722, 1.16034621548945, 0.139671990030794, 0.0977977972685849, 1.077193675942, NULL, , , , 1.32253234039183, 1.04766882020295, 1.66950830038396, 0.428274716668983, 0.088929547530482, 0.64122445337358, 0.16901652599532, 0.0240214688530384, 0.314011583137601, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0195082647991621, m4 = NULL), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), FALSE, 6.3335201530061, 4.69462026698612, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 0.234363564503757, 0.444418781824495, 6.3335201530061, 2.39629990758453e-10, 6.3335201530061, Common effect model, common, NA, 0.0824475186200081, NA, 1, FALSE, FALSE
OR	26	12	1.254	1.398	1.559	<.001	.20 [.00, .50]	random	SSW	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 6.03946118687454, 1.54629701123876e-09, 0.95, 0.226343213164649, 0.44383302818103, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554855277262352, 6.03919858753366, 1.54881534132051e-09, classic, Inf, 0.22633848466622, 0.443837756679459, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.03946118687454, 6.03919858753366, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 0.226343213164649, 0.44383302818103, 6.03946118687454, 1.54629701123876e-09, 6.03946118687454, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE

Excluding Cosenza 1993

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	15	8	0.931	1.197	1.539	.16	.10 [.00, .47]	random	GLMM	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, 1.40303311828977, 0.160606963349253, 0.95, -0.0714351311309446, 0.431357199953919, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411507, 0.128265706958137, 1.40303311523666, 0.160606964259642, classic, Inf, -0.0714351316780093, 0.431357200501024, 0.159319592568877, , NA, 0.152612926946346, NA, NA, NA, HTS, , NA, 0.128265706958137, 13, 0.95, -0.0971401785998927, 0.457062247422907, 0.152612926946346, 0.152612926946346, c(Wald = 15.525097599313, LRT = 25.5970217762644), c(14, 14), c(0.343227150566456, 0.0291110645295176), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0530600850892, 1, 1.37866063469329, 0.0982343324772731, 0, 0.473879469265866, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0713467333343363, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.40303311828977, 1.40303311523666, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, -0.0714351311309446, 0.431357199953919, 1.40303311828977, 0.160606963349253, 1.40303311828977, Common effect model, common, NA, 0.152612926946346, NA, 1, FALSE, FALSE, list(b = 0.179961034411487, beta = 0.179961034411487, se = 0.128265706679007, zval = 1.40303311828977, pval = 0.160606963349253, ci.lb = -0.0714351311309446, ci.ub = 0.431357199953919, vb = 0.016452091509865, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.9685019310179, QMdf = c(1, NA), QMp = 0.160606963349253, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373256496, 25.5970217762644, 175.082474651299, 197.501632757894, 216.928628497453), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000001), list(b = 0.179961034411507, beta = 0.179961034411507, se = 0.128265706958137, zval = 1.40303311523666, pval = 0.160606964259642, ci.lb = -0.0714351316780093, ci.ub = 0.431357200501024, vb = 0.0164520915814706, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.96850192245069, QMdf = c(1, NA), QMp = 0.160606964259642, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373258649, 25.597021776695, 177.08247465173, 200.902830139986, 228.08247465173), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.405999999999999), 4.2-0, UM.FS
OR	15	8	0.856	1.191	1.656	.30	.20 [.00, .57]	random	Inverse	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.276223022572002, 0.125865609297095, 2.1945869416959, 0.0281932411040091, 0.95, 0.0295309614575067, 0.522915083686497, c(0.391109170090123, 0.734282336265172, 6.46388416159709, 3.69114390737369, 2.92023358912231, 3.92891355804134, 3.81554745747395, 0.84219307084954, 0.875358712986259, 4.44919465053675, 0.454041053492377, 0.452624890585364, 0.431246939898614, 0.431115283745135, 5.47810847606504), 0.174502452693253, 0.168170583013807, 1.03765147010833, 0.299432346167281, classic, Inf, -0.155105833272913, 0.504110738659418, 0.168170583013807, , NA, 0.155677088081055, NA, NA, NA, HTS, , NA, 0.351948058201423, 13, 0.95, -0.585835100948044, 0.934840006334549, 0.155677088081055, 0.155677088081055, 17.5660219899502, 14, 0.227266534008463, REML, NULL, QP, 0.0955860906805483, 0.127311143846468, 0, 0.783254323903205, 0.309170002879562, 0, 0.885016567021886, NULL, , , , 1.12014099845734, 1, 1.51834076396481, 0.203006804385783, 0, 0.566228018824169, 0.225321887885879, 0, 0.722062825277491, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0955860906805483, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 2.1945869416959, 1.03765147010833, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.276223022572002, 0.125865609297095, 0.0295309614575067, 0.522915083686497, 2.1945869416959, 0.0281932411040091, 2.1945869416959, Common effect model, common, NA, 0.155677088081055, NA, 1, FALSE, FALSE
OR	15	8	0.856	1.191	1.656	.30	.20 [.00, .57]	random	MH	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 15, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.174363674204894, 0.126364772711953, 1.37984400606927, 0.167634679996714, 0.95, -0.0733067292251229, 0.422034077634911, c(0.391109170090123, 0.734282336265172, 6.46388416159709, 3.69114390737369, 2.92023358912231, 3.92891355804134, 3.81554745747395, 0.84219307084954, 0.875358712986259, 4.44919465053675, 0.454041053492377, 0.452624890585364, 0.431246939898614, 0.431115283745135, 5.47810847606504), 0.174502452693253, 0.168170583013807, 1.03765147010833, 0.299432346167281, classic, Inf, -0.155105833272913, 0.504110738659418, 0.168170583013807, , NA, 0.155677088081055, NA, NA, NA, HTS, , NA, 0.351948058201423, 13, 0.95, -0.585835100948044, 0.934840006334549, 0.155677088081055, 0.155677088081055, 17.5660219899502, 14, 0.227266534008463, REML, NULL, QP, 0.0955860906805483, 0.127311143846468, 0, 0.783254323903205, 0.309170002879562, 0, 0.885016567021886, NULL, , , , 1.12014099845734, 1, 1.51834076396481, 0.203006804385783, 0, 0.566228018824169, 0.225321887885879, 0, 0.722062825277491, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0955860906805483, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.37984400606927, 1.03765147010833, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.174363674204894, 0.126364772711953, -0.0733067292251229, 0.422034077634911, 1.37984400606927, 0.167634679996714, 1.37984400606927, Common effect model, common, NA, 0.155677088081055, NA, 1, FALSE, FALSE
OR	15	8	0.7	1.033	1.526	.87	.43 [.00, .69]	random	Peto	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-1.43684210526316, -0.690261338333529, 1.00795306164762, 0.212037275367835, -0.358939974457216, -0.245902766320189, -0.103975776405053, -0.96814727649067, 2.71520154460688, 0.288825505247073, -1.15352537697584, -1.02389642850852, -1.24149907767122, -1.11687158278867, 0.510435812545122), c(1.56089219338149, 0.919851510749532, 0.295964545973394, 0.447210581153716, 0.4779292284239, 0.400819752502115, 0.39928626800966, 0.618795351373702, 1.39946633835025, 0.379240441958542, 0.986041272695215, 2.27870185976276, 1.26445115535852, 1.63695215942607, 0.32406897670339), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), c(0.357297866196262, 0.453010712212803, 0.000660055934616421, 0.635405097974775, 0.452633611523925, 0.539546033178936, 0.794552090065137, 0.117684285849375, 0.052359125243574, 0.446305096005573, 0.242059299632813, 0.653191301938128, 0.326174643421658, 0.495057335302806, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -2.49313717052737, 0.427873210839015, -0.664479357198675, -1.29566404932708, -1.03149504551659, -0.886562481225394, -2.18096387898393, -0.0277020761357525, -0.454472102472721, -3.0861307587285, -5.49007000514796, -3.71977780238397, -4.32523885967883, -0.124727710300273), c(1.62245037751428, 1.11261449386031, 1.58803291245622, 1.08855390793435, 0.577784100412645, 0.539689512876215, 0.678610928415287, 0.244669326002593, 5.45810516534952, 1.03212311296687, 0.779080004776819, 3.44227714813093, 1.23677964704154, 2.09149569410149, 1.14559933539052), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.186189875281927, 0.132802971262727, 1.40200082506878, 0.160915000315767, 0.95, -0.0740991654329242, 0.446478915996779, c(0.378692801209728, 0.952013582553891, 3.42614307030031, 2.47355960443878, 2.31109818865527, 2.7402151092779, 2.74945908603699, 1.70303768585856, 0.462366935192014, 2.87272375141039, 0.849938459793775, 0.185296344277287, 0.554595764734295, 0.346753773291822, 3.23311661837876), 0.0328084278623807, 0.199050757874369, 0.164824430777037, 0.869082174056427, classic, Inf, -0.357323888666784, 0.422940744391546, 0.199050757874369, , NA, 0.199001345850416, NA, NA, NA, HTS, , NA, 0.493861907733873, 13, 0.95, -1.0341153582268, 1.09973221395156, 0.199001345850416, 0.199001345850416, 24.5494365839324, 14, 0.0392848978880235, REML, NULL, QP, 0.20427837970018, 0.19124804313984, 0, 1.55208980585594, 0.451971658071809, 0, 1.24582896332359, NULL, , , , 1.32420964524753, 1, 1.79453478479783, 0.429722146488568, 0, 0.689475237712166, 0.343718948429073, 0.0317839812798917, 0.655653915578255, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.20427837970018, m4 = NULL), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), FALSE, 1.40200082506878, 0.164824430777037, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.186189875281927, 0.132802971262727, -0.0740991654329242, 0.446478915996779, 1.40200082506878, 0.160915000315767, 1.40200082506878, Common effect model, common, NA, 0.199001345850416, NA, 1, FALSE, FALSE
OR	15	8	0.868	1.24	1.773	.24	.20 [.00, .57]	random	SSW	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.215404682196579, 0.144102046027313, 1.49480654949029, 0.134964936543598, 0.95, -0.0670301381154883, 0.497839502508646, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.215404682196579, 0.182234761764639, 1.18201752569457, 0.23719874694635, classic, Inf, -0.141768887593352, 0.572578251986509, 0.168170583013807, , NA, 0.155677088081055, NA, NA, NA, HTS, , NA, 0.351948058201423, 13, 0.95, -0.585835100948044, 0.934840006334549, 0.155677088081055, 0.155677088081055, 17.5660219899502, 14, 0.227266534008463, REML, NULL, QP, 0.0955860906805483, 0.127311143846468, 0, 0.783254323903205, 0.309170002879562, 0, 0.885016567021886, NULL, , , , 1.12014099845734, 1, 1.51834076396481, 0.203006804385783, 0, 0.566228018824169, 0.225321887885879, 0, 0.722062825277491, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0955860906805483, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.49480654949029, 1.18201752569457, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.215404682196579, 0.144102046027313, -0.0670301381154883, 0.497839502508646, 1.49480654949029, 0.134964936543598, 1.49480654949029, Common effect model, common, NA, 0.155677088081055, NA, 1, FALSE, FALSE
Art
OR	15	8	1.214	1.664	2.28	.002	.63 [.35, .79]	random	GLMM	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 6.05584659721025, 1.3968106840473e-09, 0.95, 0.350885004278312, 0.686696372003195, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.509221366141504, 0.16072099805689, 3.16835617186285, 0.00153303581743651, classic, Inf, 0.194213998390667, 0.82422873389234, 0.178675347905303, , NA, 0.197132683629707, NA, NA, NA, HTS, , NA, 0.462893849380224, 13, 0.95, -0.490799997328941, 1.50924272961195, 0.197132683629707, 0.197132683629707, c(Wald = 37.618748688579, LRT = 48.5537501287027), c(14, 14), c(0.000594190753481038, 1.0640792776045e-05), ML, NULL, , 0.188439476577639, NA, NA, NA, 0.434096160519347, NA, NA, NULL, , , , 1.63922343741042, 1.24072588606055, 2.1657108213381, 0.627845144029196, 0.35039656394325, 0.786794174514572, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.234894125055536, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.05584659721025, 3.16835617186285, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 0.350885004278312, 0.686696372003195, 6.05584659721025, 1.3968106840473e-09, 6.05584659721025, Common effect model, common, NA, 0.197132683629707, NA, 1, FALSE, FALSE, list(b = 0.518790688140753, beta = 0.518790688140753, se = 0.0856677394007545, zval = 6.05584659721025, pval = 1.3968106840473e-09, ci.lb = 0.350885004278312, ci.ub = 0.686696372003195, vb = 0.00733896157403559, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 36.6732780089429, QMdf = c(1, NA), QMp = 1.3968106840473e-09, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-90.8130732941009, 48.5537501287027, 213.626146588202, 236.045304694796, 255.472300434356), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0210000000000008), list(b = 0.509221366141504, beta = 0.509221366141504, se = 0.16072099805689, zval = 3.16835617186285, pval = 0.00153303581743651, ci.lb = 0.194213998390667, ci.ub = 0.82422873389234, vb = 0.0258312392164028, tau2 = 0.188439476577639, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 57.4593300338307, H2 = 2.3506917046564, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 10.0384808317814, QMdf = c(1, NA), QMp = 0.0015330358174365, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-73.0465175765165, 13.020638693534, 180.093035153033, 203.91339064129, 231.093035153033), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.656000000000001), 4.2-0, UM.FS
OR	15	8	1.158	1.678	2.432	.006	.64 [.37, .79]	random	Inverse	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.524636511555509, 0.0919785101649868, 5.7039031249195, 1.17094642473175e-08, 0.95, 0.344361944280483, 0.704911078830534, c(1.99127179073278, 2.45169623572036, 0.545631150053418, 0.651103228191661, 0.367921797466826, 1.06138102702342, 1.2398876789315, 0.761690894857145, 2.84764152621076, 2.45159214999965, 2.72110805857795, 1.99896412321813, 3.24015095367126, 2.75769666004895, 2.83117599713607), 0.517743229258522, 0.189256474270053, 2.73566984302871, 0.00622534509958398, classic, Inf, 0.146807355848187, 0.888679102668857, 0.189256474270053, , NA, 0.200744271170943, NA, NA, NA, HTS, , NA, 0.562455947583444, 13, 0.95, -0.697368970541828, 1.73285542905887, 0.200744271170943, 0.200744271170943, 38.8746736459616, 14, 0.000381349730357115, REML, NULL, QP, 0.280538679918858, 0.184027876733151, 0.0701539885450905, 1.64635666774119, 0.529659022314223, 0.264865982234583, 1.28310430898707, NULL, , , , 1.66636202647653, 1.26399159505296, 2.19682030652003, 0.639868359346231, 0.374090378207437, 0.792789894763819, 0.522155671603403, 0.24931549760105, 0.794995845605756, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.280538679918858, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.7039031249195, 2.73566984302871, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.524636511555509, 0.0919785101649868, 0.344361944280483, 0.704911078830534, 5.7039031249195, 1.17094642473175e-08, 5.7039031249195, Common effect model, common, NA, 0.200744271170943, NA, 1, FALSE, FALSE
OR	15	8	1.158	1.678	2.432	.006	.64 [.37, .79]	random	MH	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 14, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.535981900119464, 0.0871950096567491, 6.14693320442769, 7.89953748688502e-10, 0.95, 0.365082821560614, 0.706880978678314, c(1.99127179073278, 2.45169623572036, 0.545631150053418, 0.651103228191661, 0.367921797466826, 1.06138102702342, 1.2398876789315, 0.761690894857145, 2.84764152621076, 2.45159214999965, 2.72110805857795, 1.99896412321813, 3.24015095367126, 2.75769666004895, 2.83117599713607), 0.517743229258522, 0.189256474270053, 2.73566984302871, 0.00622534509958398, classic, Inf, 0.146807355848187, 0.888679102668857, 0.189256474270053, , NA, 0.200744271170943, NA, NA, NA, HTS, , NA, 0.562455947583444, 13, 0.95, -0.697368970541828, 1.73285542905887, 0.200744271170943, 0.200744271170943, 38.8746736459616, 14, 0.000381349730357115, REML, NULL, QP, 0.280538679918858, 0.184027876733151, 0.0701539885450905, 1.64635666774119, 0.529659022314223, 0.264865982234583, 1.28310430898707, NULL, , , , 1.66636202647653, 1.26399159505296, 2.19682030652003, 0.639868359346231, 0.374090378207437, 0.792789894763819, 0.522155671603403, 0.24931549760105, 0.794995845605756, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.280538679918858, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.14693320442769, 2.73566984302871, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.535981900119464, 0.0871950096567491, 0.365082821560614, 0.706880978678314, 6.14693320442769, 7.89953748688502e-10, 6.14693320442769, Common effect model, common, NA, 0.200744271170943, NA, 1, FALSE, FALSE
OR	15	8	1.145	1.663	2.417	.008	.68 [.46, .81]	random	Peto	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.37380660954712, 0.737734224795348, -0.12052903696899, -0.898720357210923, 2.88135593220339, 1.886625, -0.749367968408782, 0.0609904207495266, 0.313395219413491, 0.117134174635773, 0.510435812545122, 0.0562064185176206, 0.371336934921835, 0.213083622484386, 1.50046978291384), c(0.415528842183368, 0.342493017102583, 1.21687522422527, 0.876931092336367, 1.48876715444574, 0.673934343983151, 0.453165389135724, 1.04464964727608, 0.287580331760914, 0.372381982228678, 0.32406897670339, 0.475482940518229, 0.17013786477182, 0.286867912404376, 0.233931487850484), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), c(0.000945826213271411, 0.0312391951359797, 0.921100172165413, 0.305435300635845, 0.0529415602967437, 0.00511945666092442, 0.0982026747675452, 0.953443067420015, 0.275816308736864, 0.753100447472451, 0.115237090566695, 0.905901966336454, 0.0290678656470361, 0.457606707594208, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, 0.0664602463178242, -2.50556065012963, -2.61747371511357, -0.0365740718764318, 0.565737957848396, -1.63755581015488, -1.98648526437405, -0.250251873499981, -0.61272109902407, -0.124727710300273, -0.87572302016131, 0.0378728475625207, -0.349167154148383, 1.04197249187702), c(2.18822817476415, 1.40900820327287, 2.26450257619165, 0.820033000691724, 5.79928593628321, 3.2075120421516, 0.138819873337315, 2.10846610587311, 0.877042312326963, 0.846989448295615, 1.14559933539052, 0.988135857196551, 0.704801022281149, 0.775334399117154, 1.95896707395066), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.548480113736861, 0.0901851513332921, 6.08171196286931, 1.18906037822996e-09, 0.95, 0.371720465183315, 0.725239762290408, c(2.07025168145471, 2.33824978348744, 0.558299239504154, 0.926460373664246, 0.395758031256081, 1.30794808558885, 1.93900770232745, 0.713438900726539, 2.54406779358424, 2.22698708502744, 2.40737886240427, 1.8640966686541, 2.94710768003426, 2.54671932257952, 2.73902978801839), 0.508858514794026, 0.190606587516095, 2.66967958151529, 0.00759236609368862, classic, Inf, 0.135276468046398, 0.882440561541653, 0.190606587516095, , NA, 0.200194976047696, NA, NA, NA, HTS, , NA, 0.588812117967858, 13, 0.95, -0.763192729409207, 1.78090975899726, 0.200194976047696, 0.200194976047696, 44.2017535327236, 14, 5.49254954510591e-05, REML, NULL, QP, 0.310368839061264, 0.190949448524953, 0.0898124769936201, 1.60801246685452, 0.557107565072728, 0.299687298685847, 1.26807431440532, NULL, , , , 1.77687031307303, 1.35932256963925, 2.32267761898353, 0.683270484062686, 0.458803543492753, 0.814637392651624, 0.569522702082554, 0.314770273665654, 0.824275130499454, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.310368839061264, m4 = NULL), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), FALSE, 6.08171196286931, 2.66967958151529, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.548480113736861, 0.0901851513332921, 0.371720465183315, 0.725239762290408, 6.08171196286931, 1.18906037822996e-09, 6.08171196286931, Common effect model, common, NA, 0.200194976047696, NA, 1, FALSE, FALSE
OR	15	8	1.132	1.666	2.45	.010	.64 [.37, .79]	random	SSW	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.510142404739326, 0.115584524591159, 4.41358742914574, 1.01671631006477e-05, 0.95, 0.28360089937047, 0.736683910108181, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.510142404739326, 0.196836725634331, 2.59170336783102, 0.00955020771858088, classic, Inf, 0.124349511661246, 0.895935297817406, 0.189256474270053, , NA, 0.200744271170943, NA, NA, NA, HTS, , NA, 0.562455947583444, 13, 0.95, -0.697368970541828, 1.73285542905887, 0.200744271170943, 0.200744271170943, 38.8746736459616, 14, 0.000381349730357115, REML, NULL, QP, 0.280538679918858, 0.184027876733151, 0.0701539885450905, 1.64635666774119, 0.529659022314223, 0.264865982234583, 1.28310430898707, NULL, , , , 1.66636202647653, 1.26399159505296, 2.19682030652003, 0.639868359346231, 0.374090378207437, 0.792789894763819, 0.522155671603403, 0.24931549760105, 0.794995845605756, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.280538679918858, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 4.41358742914574, 2.59170336783102, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.510142404739326, 0.115584524591159, 0.28360089937047, 0.736683910108181, 4.41358742914574, 1.01671631006477e-05, 4.41358742914574, Common effect model, common, NA, 0.200744271170943, NA, 1, FALSE, FALSE
Music
OR	24	11	1.238	1.368	1.512	<.001	.00 [.00, .45]	random	GLMM	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 6.12619620351618, 9.00048085245428e-10, 0.95, 0.213127522239714, 0.413655119238019, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738951, 0.0511559443992605, 6.12619558526772, 9.00051580728392e-10, classic, Inf, 0.213127512121267, 0.413655129356635, 0.0516471199100862, , NA, 0.0559606871984727, NA, NA, NA, HTS, , NA, 0.0511559443992605, 22, 0.95, 0.207300385386129, 0.419482256091773, 0.0559606871984727, 0.0559606871984727, c(Wald = 21.5987482461991, LRT = 38.9280222931132), c(23, 23), c(0.544572196999553, 0.0202043825060466), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.34362867816388, 0, 0, 0.44608711151508, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 3.86448812170193e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.12619620351618, 6.12619558526772, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 0.213127522239714, 0.413655119238019, 6.12619620351618, 9.00048085245428e-10, 6.12619620351618, Common effect model, common, NA, 0.0559606871984727, NA, 1, FALSE, FALSE, list(b = 0.313391320738867, beta = 0.313391320738867, se = 0.0511559392366495, zval = 6.12619620351618, pval = 9.00048085245428e-10, ci.lb = 0.213127522239714, ci.ub = 0.413655119238019, vb = 0.00261693011918378, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302799239761, QMdf = c(1, NA), QMp = 9.00048085245431e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 25, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926454, 38.9280222931132, 322.753451852909, 369.533477125606, 381.844360943818), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0250000000000004), list(b = 0.313391320738951, beta = 0.313391320738951, se = 0.0511559443992605, zval = 6.12619558526772, pval = 9.00051580728392e-10, ci.lb = 0.213127512121267, ci.ub = 0.413655129356635, vb = 0.00261693064738023, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302723489537, QMdf = c(1, NA), QMp = 9.00051580728395e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 26, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926643, 38.9280222934896, 324.753451853285, 373.40467813689, 391.610594710428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.137), 4.2-0, UM.FS
OR	24	11	1.258	1.392	1.54	<.001	.15 [.00, .48]	random	Inverse	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.330652918047755, 0.0516467683650575, 6.40219956669087, 1.53154293790548e-10, 0.95, 0.22942711213436, 0.43187872396115, c(5.22170345681797, 0.427776578362462, 0.953711729823298, 5.70178484705028, 7.75727474749534, 42.6479678213221, 25.2338317810609, 41.4640025711007, 54.4336362465548, 33.9412376824018, 51.1514914605539, 2.5234281473921, 4.32123076735579, 10.7592679804966, 5.53895651862921, 2.66595163506462, 17.8489677563778, 19.8068042067818, 0.480400885424716, 0.478815802696037, 0.908224656276111, 0.478763613182121, 4.5512368905155, 35.6011467642817), 0.330652770945137, 0.051646828942713, 6.40218920917485, 1.53164686872999e-10, classic, Inf, 0.229426846301718, 0.431878695588555, 0.051646828942713, , NA, 0.0559604738283961, NA, NA, NA, HTS, , NA, 0.051647473623738, 22, 0.95, 0.223542466371583, 0.43776307551869, 0.0559604738283961, 0.0559604738283961, 27.0024772298147, 23, 0.255862189889285, REML, NULL, QP, 6.65918768545846e-08, 0.0132110542881194, 0, 0.233978135687717, 0.000258054019256792, 0, 0.483712864918556, NULL, , , , 1.08352238053599, 1, 1.38492618426474, 0.148226297748542, 0, 0.478629148487957, 1.04021399087469e-06, 0, 0.324459769600557, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.65918768545846e-08, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.40219956669087, 6.40218920917485, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.330652918047755, 0.0516467683650575, 0.22942711213436, 0.43187872396115, 6.40219956669087, 1.53154293790548e-10, 6.40219956669087, Common effect model, common, NA, 0.0559604738283961, NA, 1, FALSE, FALSE
OR	24	11	1.258	1.392	1.54	<.001	.15 [.00, .48]	random	MH	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 23, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.314382696277929, 0.0512589242858317, 6.13322851889865, 8.61133114134143e-10, 0.95, 0.213917050791434, 0.414848341764425, c(5.22170345681797, 0.427776578362462, 0.953711729823298, 5.70178484705028, 7.75727474749534, 42.6479678213221, 25.2338317810609, 41.4640025711007, 54.4336362465548, 33.9412376824018, 51.1514914605539, 2.5234281473921, 4.32123076735579, 10.7592679804966, 5.53895651862921, 2.66595163506462, 17.8489677563778, 19.8068042067818, 0.480400885424716, 0.478815802696037, 0.908224656276111, 0.478763613182121, 4.5512368905155, 35.6011467642817), 0.330652770945137, 0.051646828942713, 6.40218920917485, 1.53164686872999e-10, classic, Inf, 0.229426846301718, 0.431878695588555, 0.051646828942713, , NA, 0.0559604738283961, NA, NA, NA, HTS, , NA, 0.051647473623738, 22, 0.95, 0.223542466371583, 0.43776307551869, 0.0559604738283961, 0.0559604738283961, 27.0024772298147, 23, 0.255862189889285, REML, NULL, QP, 6.65918768545846e-08, 0.0132110542881194, 0, 0.233978135687717, 0.000258054019256792, 0, 0.483712864918556, NULL, , , , 1.08352238053599, 1, 1.38492618426474, 0.148226297748542, 0, 0.478629148487957, 1.04021399087469e-06, 0, 0.324459769600557, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.65918768545846e-08, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.13322851889865, 6.40218920917485, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.314382696277929, 0.0512589242858317, 0.213917050791434, 0.414848341764425, 6.13322851889865, 8.61133114134143e-10, 6.13322851889865, Common effect model, common, NA, 0.0559604738283961, NA, 1, FALSE, FALSE
OR	24	11	1.176	1.344	1.537	<.001	.39 [.00, .62]	random	Peto	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, 1.17826257861635, -0.100526663026663, -0.301878909223286, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.490670728524915, 0.452618839163683, 0.441543762495517, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, -0.172032692354803, 0.516686677945751, -1.15406139984312, -1.02444480232342, -0.660637623336967, -1.11800549988975, 0.0562064185176206, 0.371336934921835), c(0.540780565579624, 1.32219331813667, 1.13845897443781, 0.417348609294271, 0.355932285189848, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 0.22726902886927, 0.244167347549023, 0.854369065122966, 1.97448261801463, 0.763018377649432, 0.988187320844407, 0.475482940518229, 0.17013786477182), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), c(0.10990091605911, 0.00351376944795559, 0.300686329135404, 0.809656053389246, 0.396362352687967, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.449076125152964, 0.0343348569588449, 0.176767133978651, 0.603870823550084, 0.386588123690052, 0.257899388302445, 0.905901966336454, 0.0290678656470361), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -1.05307600915816, -0.918514906241311, -0.999493369130427, 0.126119628474816, -0.109459222670617, 0.15271233326912, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, -0.617471803739965, 0.0381274705489931, -2.82859399698928, -4.89435962173246, -2.15612616307204, -3.05481705872391, -0.87572302016131, 0.0378728475625207), c(1.92442314671454, 6.45067458511826, 3.40960116639086, 0.717461580187986, 0.395735550683856, 0.761269452833273, 0.727504996658277, 0.801769440950646, 0.771661460016443, 0.820306387820303, 0.731535599651959, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 0.273406419030359, 0.995245885342509, 0.520471197303052, 2.84547001708561, 0.834850916398102, 0.818806058944414, 0.988135857196551, 0.704801022281149), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.330291042771478, 0.0537935450573156, 6.13997538960413, 8.25342666315198e-10, 0.95, 0.224857631858407, 0.43572445368455, c(3.18104119605861, 0.564935355974581, 0.758720910815316, 5.0994723014296, 6.72917388535513, 20.758557966543, 14.8131464472911, 20.2694988806575, 23.5446710904622, 17.5093644682446, 22.8256553285442, 2.66840476220503, 3.27086767510592, 10.4467693405817, 4.56191303541623, 3.23452719790578, 13.5924837185327, 12.2644379074065, 1.33002536601664, 0.255069475931728, 1.65531149269416, 1.00156941804802, 4.03221112808808, 19.6595929229885), 0.296014631113954, 0.0683542134981177, 4.33059815869442, 1.48704838355182e-05, classic, Inf, 0.162042834466081, 0.429986427761826, 0.0683542134981177, , NA, 0.0799502037451487, NA, NA, NA, HTS, , NA, 0.16306795697119, 22, 0.95, -0.0421676130867304, 0.634196875314638, 0.0799502037451487, 0.0799502037451487, 37.4891693622925, 23, 0.0288754624882353, REML, NULL, QP, 0.0219188600878117, 0.0254848758130457, 0, 0.715788315665502, 0.148050194487585, 0, 0.846042738675477, NULL, , , , 1.27670038980062, 1, 1.63183548663982, 0.386489474393798, 0, 0.624467737769533, 0.195468212575942, 0.00536222066519287, 0.385574204486692, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0219188600878117, m4 = NULL), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), FALSE, 6.13997538960413, 4.33059815869442, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.330291042771478, 0.0537935450573156, 0.224857631858407, 0.43572445368455, 6.13997538960413, 8.25342666315198e-10, 6.13997538960413, Common effect model, common, NA, 0.0799502037451487, NA, 1, FALSE, FALSE
OR	24	11	1.248	1.392	1.553	<.001	.15 [.00, .48]	random	SSW	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.330897992021532, 0.0556711930652914, 5.9437920008909, 2.78502954587369e-09, 0.95, 0.221784458637185, 0.440011525405879, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.330897992021532, 0.0556712475735727, 5.94378618126406, 2.78512847426299e-09, classic, Inf, 0.221784351802916, 0.440011632240147, 0.051646828942713, , NA, 0.0559604738283961, NA, NA, NA, HTS, , NA, 0.051647473623738, 22, 0.95, 0.223542466371583, 0.43776307551869, 0.0559604738283961, 0.0559604738283961, 27.0024772298147, 23, 0.255862189889285, REML, NULL, QP, 6.65918768545846e-08, 0.0132110542881194, 0, 0.233978135687717, 0.000258054019256792, 0, 0.483712864918556, NULL, , , , 1.08352238053599, 1, 1.38492618426474, 0.148226297748542, 0, 0.478629148487957, 1.04021399087469e-06, 0, 0.324459769600557, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.65918768545846e-08, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 5.9437920008909, 5.94378618126406, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.330897992021532, 0.0556711930652914, 0.221784458637185, 0.440011525405879, 5.9437920008909, 2.78502954587369e-09, 5.9437920008909, Common effect model, common, NA, 0.0559604738283961, NA, 1, FALSE, FALSE

Excluding Peterson 1977 and Peterson 1983

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	17	9	0.91	1.042	1.193	.55	.20 [.00, .55]	random	GLMM	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999996), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.494), 4.2-0, UM.FS
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	Inverse	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, 1.05998403613453, 0.289151861978491, 0.95, -0.061642360556288, 0.20684541370225, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.05998403613453, 1.06369532430366, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, -0.061642360556288, 0.20684541370225, 1.05998403613453, 0.289151861978491, 1.05998403613453, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	MH	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 17, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, 0.589363980337228, 0.555617133864833, 0.95, -0.0940868567215518, 0.175002374312089, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.589363980337228, 1.06369532430366, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, -0.0940868567215518, 0.175002374312089, 0.589363980337228, 0.555617133864833, 0.589363980337228, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.815	1.065	1.393	.64	.40 [.00, .66]	random	Peto	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-1.43684210526316, -0.690261338333529, 1.00795306164762, 0.212037275367835, -0.358939974457216, -0.245902766320189, -0.103975776405053, -0.96814727649067, 2.71520154460688, 0.288825505247073, 0.0676634264671485, -0.0375389837855228, -1.15352537697584, -1.02389642850852, -1.24149907767122, -1.11687158278867, 0.510435812545122), c(1.56089219338149, 0.919851510749532, 0.295964545973394, 0.447210581153716, 0.4779292284239, 0.400819752502115, 0.39928626800966, 0.618795351373702, 1.39946633835025, 0.379240441958542, 0.171431799285525, 0.0929909160392439, 0.986041272695215, 2.27870185976276, 1.26445115535852, 1.63695215942607, 0.32406897670339), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), c(0.357297866196262, 0.453010712212803, 0.000660055934616421, 0.635405097974775, 0.452633611523925, 0.539546033178936, 0.794552090065137, 0.117684285849375, 0.052359125243574, 0.446305096005573, 0.693067336878847, 0.686444799637499, 0.242059299632813, 0.653191301938128, 0.326174643421658, 0.495057335302806, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -2.49313717052737, 0.427873210839015, -0.664479357198675, -1.29566404932708, -1.03149504551659, -0.886562481225394, -2.18096387898393, -0.0277020761357525, -0.454472102472721, -0.26833672593738, -0.219797830111829, -3.0861307587285, -5.49007000514796, -3.71977780238397, -4.32523885967883, -0.124727710300273), c(1.62245037751428, 1.11261449386031, 1.58803291245622, 1.08855390793435, 0.577784100412645, 0.539689512876215, 0.678610928415287, 0.244669326002593, 5.45810516534952, 1.03212311296687, 0.403663578871677, 0.144719862540783, 0.779080004776819, 3.44227714813093, 1.23677964704154, 2.09149569410149, 1.14559933539052), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, 0.592961663805544, 0.553206808576661, 0.95, -0.0951582454177123, 0.177711421329491, c(0.395391907150482, 1.06510043053455, 5.54487213854294, 3.41589434911937, 3.11363383013073, 3.94620110640505, 3.96540075258979, 2.10234428946293, 0.487505756565418, 4.22698736188081, 8.18728184765695, 9.86201973008252, 0.938941402440821, 0.189206382731604, 0.591160313115281, 0.360702973669442, 5.05631473520319), 0.0630490798536173, 0.13678244836612, 0.460944226446775, 0.644838620359311, classic, Inf, -0.205039592661188, 0.331137752368423, 0.13678244836612, , NA, 0.143767123196811, NA, NA, NA, HTS, , NA, 0.333858106594923, 15, 0.95, -0.648552629729578, 0.774650789436813, 0.143767123196811, 0.143767123196811, 26.4821853167165, 16, 0.047609917873651, REML, NULL, QP, 0.0927517971581165, 0.0891761562969764, 0, 1.08061331145796, 0.304551797167767, 0, 1.03952552227348, NULL, , , , 1.28652111614803, 1, 1.71725833898097, 0.395820253931225, 0, 0.660899264276656, 0.291616884234202, 0, 0.613097971938004, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0927517971581165, m4 = NULL), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), FALSE, 0.592961663805544, 0.460944226446775, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, -0.0951582454177123, 0.177711421329491, 0.592961663805544, 0.553206808576661, 0.592961663805544, Common effect model, common, NA, 0.143767123196811, NA, 1, FALSE, FALSE
OR	17	9	0.854	1.101	1.42	.46	.26 [.00, .59]	random	SSW	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, 1.20554350941747, 0.227993552034675, 0.95, -0.0602854100327486, 0.252954318616497, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.129638051538024, 0.743103225858177, 0.457419186766786, classic, Inf, -0.1577514577486, 0.350420366332349, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.20554350941747, 0.743103225858177, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, -0.0602854100327486, 0.252954318616497, 1.20554350941747, 0.227993552034675, 1.20554350941747, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
Art
OR	17	9	1.247	1.598	2.048	<.001	.59 [.30, .76]	random	GLMM	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000019), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.757999999999999), 4.2-0, UM.FS
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	Inverse	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 5.59787281727964, 2.16997844692742e-08, 0.95, 0.314512352102863, 0.653406431727379, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.59787281727964, 2.88818727880593, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 0.314512352102863, 0.653406431727379, 5.59787281727964, 2.16997844692742e-08, 5.59787281727964, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	MH	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 16, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 6.03879245958711, 1.55271798516199e-09, 0.95, 0.335531503617244, 0.657991576057912, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.03879245958711, 2.88818727880593, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 0.335531503617244, 0.657991576057912, 6.03879245958711, 1.55271798516199e-09, 6.03879245958711, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.152	1.596	2.212	.005	.65 [.42, .79]	random	Peto	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.37380660954712, 0.737734224795348, -0.12052903696899, -0.898720357210923, 2.88135593220339, 1.886625, 0.146763960036387, 0.190703412437214, -0.749367968408782, 0.0609904207495266, 0.313395219413491, 0.117134174635773, 0.510435812545122, 0.0562064185176206, 0.371336934921835, 0.213083622484386, 1.50046978291384), c(0.415528842183368, 0.342493017102583, 1.21687522422527, 0.876931092336367, 1.48876715444574, 0.673934343983151, 0.565457624206178, 0.294238027642615, 0.453165389135724, 1.04464964727608, 0.287580331760914, 0.372381982228678, 0.32406897670339, 0.475482940518229, 0.17013786477182, 0.286867912404376, 0.233931487850484), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), c(0.000945826213271411, 0.0312391951359797, 0.921100172165413, 0.305435300635845, 0.0529415602967437, 0.00511945666092442, 0.795211681566248, 0.51690324668251, 0.0982026747675452, 0.953443067420015, 0.275816308736864, 0.753100447472451, 0.115237090566695, 0.905901966336454, 0.0290678656470361, 0.457606707594208, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, 0.0664602463178242, -2.50556065012963, -2.61747371511357, -0.0365740718764318, 0.565737957848396, -0.961512618191306, -0.385992524624412, -1.63755581015488, -1.98648526437405, -0.250251873499981, -0.61272109902407, -0.124727710300273, -0.87572302016131, 0.0378728475625207, -0.349167154148383, 1.04197249187702), c(2.18822817476415, 1.40900820327287, 2.26450257619165, 0.820033000691724, 5.79928593628321, 3.2075120421516, 1.25504053826408, 0.767399349498841, 0.138819873337315, 2.10846610587311, 0.877042312326963, 0.846989448295615, 1.14559933539052, 0.988135857196551, 0.704801022281149, 0.775334399117154, 1.95896707395066), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 5.97515138157933, 2.29876620951754e-09, 0.95, 0.342256498088733, 0.676393036883093, c(2.34039020582257, 2.68877611668498, 0.576235936882886, 0.976922073540483, 0.404687479201077, 1.41083032215136, 1.74107655668937, 2.93090988293862, 2.17403673768121, 0.742992921004605, 2.96456685862538, 2.54269633016767, 2.78059189475238, 2.08030395739873, 3.52656747293488, 2.96816796823362, 3.23270045758165), 0.467416470190684, 0.166476130078398, 2.80770864850454, 0.00498953457085751, classic, Inf, 0.141129250951419, 0.793703689429949, 0.166476130078398, , NA, 0.174105471348229, NA, NA, NA, HTS, , NA, 0.531346647463955, 15, 0.95, -0.665122100081072, 1.59995504046244, 0.174105471348229, 0.174105471348229, 45.9739733189945, 16, 9.82687632317443e-05, REML, NULL, QP, 0.254614957885305, 0.153865974531026, 0.0732916386525852, 1.2351123835785, 0.504593854387174, 0.270724285302566, 1.11135610115683, NULL, , , , 1.695102749817, 1.31064081974728, 2.19234231770012, 0.651977002531789, 0.417853058300504, 0.791942552488268, 0.540419546756557, 0.298042011584244, 0.78279708192887, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.254614957885305, m4 = NULL), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), FALSE, 5.97515138157933, 2.80770864850454, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 0.342256498088733, 0.676393036883093, 5.97515138157933, 2.29876620951754e-09, 5.97515138157933, Common effect model, common, NA, 0.174105471348229, NA, 1, FALSE, FALSE
OR	17	9	1.156	1.624	2.279	.005	.61 [.33, .77]	random	SSW	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 4.45245214061084, 8.48951664069714e-06, 0.95, 0.271291286301498, 0.697950204760471, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.173122829486191, 2.79928849920766, 0.00512153558728871, classic, Inf, 0.145306234836381, 0.823935256225589, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 4.45245214061084, 2.79928849920766, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 0.271291286301498, 0.697950204760471, 4.45245214061084, 8.48951664069714e-06, 4.45245214061084, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
Music
OR	26	12	1.248	1.379	1.524	<.001	.03 [.00, .45]	random	GLMM	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0259999999999998), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.078), 4.2-0, UM.FS
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	Inverse	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 6.60558972822383, 3.95938005018008e-11, 0.95, 0.238851716327093, 0.440392170713961, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.60558972822383, 6.60513910530831, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 0.238851716327093, 0.440392170713961, 6.60558972822383, 3.95938005018008e-11, 6.60558972822383, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	MH	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 25, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 6.32363599960205, 2.55479143069901e-10, 0.95, 0.222522173794433, 0.422415953571305, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.32363599960205, 6.60513910530831, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 0.222522173794433, 0.422415953571305, 6.32363599960205, 2.55479143069901e-10, 6.32363599960205, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.2	1.367	1.558	<.001	.43 [.09, .64]	random	Peto	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, 1.17826257861635, -0.100526663026663, -0.301878909223286, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.490670728524915, 0.452618839163683, 0.441543762495517, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, -0.172032692354803, 0.516686677945751, 3.80987443815582, 1.10546580074985, -1.15406139984312, -1.02444480232342, -0.660637623336967, -1.11800549988975, 0.0562064185176206, 0.371336934921835), c(0.540780565579624, 1.32219331813667, 1.13845897443781, 0.417348609294271, 0.355932285189848, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 0.22726902886927, 0.244167347549023, 1.57151003840543, 0.663625553755456, 0.854369065122966, 1.97448261801463, 0.763018377649432, 0.988187320844407, 0.475482940518229, 0.17013786477182), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), c(0.10990091605911, 0.00351376944795559, 0.300686329135404, 0.809656053389246, 0.396362352687967, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.449076125152964, 0.0343348569588449, 0.0153362452313665, 0.0957537505474681, 0.176767133978651, 0.603870823550084, 0.386588123690052, 0.257899388302445, 0.905901966336454, 0.0290678656470361 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -1.05307600915816, -0.918514906241311, -0.999493369130427, 0.126119628474816, -0.109459222670617, 0.15271233326912, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, -0.617471803739965, 0.0381274705489931, 0.729771361538017, -0.195216383831291, -2.82859399698928, -4.89435962173246, -2.15612616307204, -3.05481705872391, -0.87572302016131, 0.0378728475625207 ), c(1.92442314671454, 6.45067458511826, 3.40960116639086, 0.717461580187986, 0.395735550683856, 0.761269452833273, 0.727504996658277, 0.801769440950646, 0.771661460016443, 0.820306387820303, 0.731535599651959, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 0.273406419030359, 0.995245885342509, 6.88997751477362, 2.406147985331, 0.520471197303052, 2.84547001708561, 0.834850916398102, 0.818806058944414, 0.988135857196551, 0.704801022281149), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 6.3335201530061, 2.39629990758453e-10, 0.95, 0.234363564503757, 0.444418781824495, c(3.2056225603369, 0.565705751325006, 0.760111130549942, 5.1629390927497, 6.8401297843006, 21.8520448228941, 15.3616893472612, 21.3107766402522, 24.9613969392452, 18.2809673841021, 24.1547311794734, 2.68568024987455, 3.296862573403, 10.7166459161808, 4.61263787309621, 3.25994543590123, 14.0529420991275, 12.6380775679207, 0.401743233696596, 2.17435197709279, 1.3343033465354, 0.255226406807943, 1.66194312120566, 1.00399343823993, 4.07178903620536, 20.6376378660032), 0.312794084274579, 0.0666281970608432, 4.69462026698612, 2.67102429424225e-06, classic, Inf, 0.182205217680489, 0.44338295086867, 0.0666281970608432, , NA, 0.0824475186200081, NA, NA, NA, HTS, , NA, 0.15475006120432, 24, 0.95, -0.00659434445686441, 0.632182513006023, 0.0824475186200081, 0.0824475186200081, 43.7272947845575, 25, 0.0116322939387831, REML, NULL, QP, 0.0195082647991621, 0.0243206297775738, 0.00956440915058722, 1.16034621548945, 0.139671990030794, 0.0977977972685849, 1.077193675942, NULL, , , , 1.32253234039183, 1.04766882020295, 1.66950830038396, 0.428274716668983, 0.088929547530482, 0.64122445337358, 0.16901652599532, 0.0240214688530384, 0.314011583137601, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0195082647991621, m4 = NULL), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), FALSE, 6.3335201530061, 4.69462026698612, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 0.234363564503757, 0.444418781824495, 6.3335201530061, 2.39629990758453e-10, 6.3335201530061, Common effect model, common, NA, 0.0824475186200081, NA, 1, FALSE, FALSE
OR	26	12	1.254	1.398	1.559	<.001	.20 [.00, .50]	random	SSW	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 6.03946118687454, 1.54629701123876e-09, 0.95, 0.226343213164649, 0.44383302818103, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554855277262352, 6.03919858753366, 1.54881534132051e-09, classic, Inf, 0.22633848466622, 0.443837756679459, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.03946118687454, 6.03919858753366, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 0.226343213164649, 0.44383302818103, 6.03946118687454, 1.54629701123876e-09, 6.03946118687454, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE

From raw proportions, using glmer()

With glmer, any number of variables can be modeled as random effects.

The model type “random” treats only each estimate as a random effect.

The model type “random (all) includes study, estimate, handedness comparison, and population (Students/Faculty/Professionals) as random effects. Because estimates might vary along all of these variables, I think it makes sense to use this model for the published analysis.

All studies

From raw proportions, with all random effects, using glmer()
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0220000000000198), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.47399999999999), 4.2-0, UM.FS
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random (all)	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999914), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.473000000000013), 4.2-0, UM.FS
Art
OR	17	9	1.38	1.611	1.882	<.001	.59 [.30, .76]	random	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999866), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.75800000000001), 4.2-0, UM.FS
OR	17	9	1.379	1.609	1.878	<.001	.59 [.30, .76]	random (all)	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.019999999999996), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.747), 4.2-0, UM.FS
Music
OR	26	12	1.251	1.38	1.523	<.001	.03 [.00, .45]	random	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999914), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.059), 4.2-0, UM.FS
OR	26	12	1.251	1.381	1.524	<.001	.03 [.00, .45]	random (all)	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0229999999999961), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.095), 4.2-0, UM.FS

Excluding Cosenza 1993

From raw proportions, with all random effects, using glmer(), excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	15	8	0.943	1.207	1.546	.13	.10 [.00, .47]	random	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, 1.40303311828977, 0.160606963349253, 0.95, -0.0714351311309446, 0.431357199953919, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411507, 0.128265706958137, 1.40303311523666, 0.160606964259642, classic, Inf, -0.0714351316780093, 0.431357200501024, 0.159319592568877, , NA, 0.152612926946346, NA, NA, NA, HTS, , NA, 0.128265706958137, 13, 0.95, -0.0971401785998927, 0.457062247422907, 0.152612926946346, 0.152612926946346, c(Wald = 15.525097599313, LRT = 25.5970217762644), c(14, 14), c(0.343227150566456, 0.0291110645295176), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0530600850892, 1, 1.37866063469329, 0.0982343324772731, 0, 0.473879469265866, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0713467333343363, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.40303311828977, 1.40303311523666, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, -0.0714351311309446, 0.431357199953919, 1.40303311828977, 0.160606963349253, 1.40303311828977, Common effect model, common, NA, 0.152612926946346, NA, 1, FALSE, FALSE, list(b = 0.179961034411487, beta = 0.179961034411487, se = 0.128265706679007, zval = 1.40303311828977, pval = 0.160606963349253, ci.lb = -0.0714351311309446, ci.ub = 0.431357199953919, vb = 0.016452091509865, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.9685019310179, QMdf = c(1, NA), QMp = 0.160606963349253, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373256496, 25.5970217762644, 175.082474651299, 197.501632757894, 216.928628497453), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.021000000000015), list(b = 0.179961034411507, beta = 0.179961034411507, se = 0.128265706958137, zval = 1.40303311523666, pval = 0.160606964259642, ci.lb = -0.0714351316780093, ci.ub = 0.431357200501024, vb = 0.0164520915814706, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.96850192245069, QMdf = c(1, NA), QMp = 0.160606964259642, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373258649, 25.597021776695, 177.08247465173, 200.902830139986, 228.08247465173), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.40100000000001), 4.2-0, UM.FS
OR	15	8	0.943	1.207	1.545	.14	.10 [.00, .47]	random (all)	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 1.97181258697412, 1, 0.160255597461704, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, 1.40303311828977, 0.160606963349253, 0.95, -0.0714351311309446, 0.431357199953919, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411507, 0.128265706958137, 1.40303311523666, 0.160606964259642, classic, Inf, -0.0714351316780093, 0.431357200501024, 0.159319592568877, , NA, 0.152612926946346, NA, NA, NA, HTS, , NA, 0.128265706958137, 13, 0.95, -0.0971401785998927, 0.457062247422907, 0.152612926946346, 0.152612926946346, c(Wald = 15.525097599313, LRT = 25.5970217762644), c(14, 14), c(0.343227150566456, 0.0291110645295176), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0530600850892, 1, 1.37866063469329, 0.0982343324772731, 0, 0.473879469265866, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544 ), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0713467333343363, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.40303311828977, 1.40303311523666, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.179961034411487, 0.128265706679007, -0.0714351311309446, 0.431357199953919, 1.40303311828977, 0.160606963349253, 1.40303311828977, Common effect model, common, NA, 0.152612926946346, NA, 1, FALSE, FALSE, list(b = 0.179961034411487, beta = 0.179961034411487, se = 0.128265706679007, zval = 1.40303311828977, pval = 0.160606963349253, ci.lb = -0.0714351311309446, ci.ub = 0.431357199953919, vb = 0.016452091509865, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.9685019310179, QMdf = c(1, NA), QMp = 0.160606963349253, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373256496, 25.5970217762644, 175.082474651299, 197.501632757894, 216.928628497453), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = 0.179961034411507, beta = 0.179961034411507, se = 0.128265706958137, zval = 1.40303311523666, pval = 0.160606964259642, ci.lb = -0.0714351316780093, ci.ub = 0.431357200501024, vb = 0.0164520915814706, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.261594380426476, QE.Wld = 15.525097599313, QEp.Wld = 0.343227150566456, QE.LRT = 25.5970217762644, QEp.LRT = 0.0291110645295176, QE.df = 14, QM = 1.96850192245069, QMdf = c(1, NA), QMp = 0.160606964259642, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 5477, 5477, 6094, 6094, 716), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-71.5412373258649, 25.597021776695, 177.08247465173, 200.902830139986, 228.08247465173), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.400999999999982), 4.2-0, UM.FS
Art
OR	15	8	1.421	1.678	1.982	<.001	.63 [.35, .79]	random	glmer	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 6.05584659721025, 1.3968106840473e-09, 0.95, 0.350885004278312, 0.686696372003195, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.509221366141504, 0.16072099805689, 3.16835617186285, 0.00153303581743651, classic, Inf, 0.194213998390667, 0.82422873389234, 0.178675347905303, , NA, 0.197132683629707, NA, NA, NA, HTS, , NA, 0.462893849380224, 13, 0.95, -0.490799997328941, 1.50924272961195, 0.197132683629707, 0.197132683629707, c(Wald = 37.618748688579, LRT = 48.5537501287027), c(14, 14), c(0.000594190753481038, 1.0640792776045e-05), ML, NULL, , 0.188439476577639, NA, NA, NA, 0.434096160519347, NA, NA, NULL, , , , 1.63922343741042, 1.24072588606055, 2.1657108213381, 0.627845144029196, 0.35039656394325, 0.786794174514572, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.234894125055536, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.05584659721025, 3.16835617186285, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 0.350885004278312, 0.686696372003195, 6.05584659721025, 1.3968106840473e-09, 6.05584659721025, Common effect model, common, NA, 0.197132683629707, NA, 1, FALSE, FALSE, list(b = 0.518790688140753, beta = 0.518790688140753, se = 0.0856677394007545, zval = 6.05584659721025, pval = 1.3968106840473e-09, ci.lb = 0.350885004278312, ci.ub = 0.686696372003195, vb = 0.00733896157403559, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 36.6732780089429, QMdf = c(1, NA), QMp = 1.3968106840473e-09, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-90.8130732941009, 48.5537501287027, 213.626146588202, 236.045304694796, 255.472300434356), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0179999999999723), list(b = 0.509221366141504, beta = 0.509221366141504, se = 0.16072099805689, zval = 3.16835617186285, pval = 0.00153303581743651, ci.lb = 0.194213998390667, ci.ub = 0.82422873389234, vb = 0.0258312392164028, tau2 = 0.188439476577639, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 57.4593300338307, H2 = 2.3506917046564, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 10.0384808317814, QMdf = c(1, NA), QMp = 0.0015330358174365, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-73.0465175765165, 13.020638693534, 180.093035153033, 203.91339064129, 231.093035153033), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.634999999999991), 4.2-0, UM.FS
OR	15	8	1.421	1.678	1.982	<.001	.63 [.35, .79]	random (all)	glmer	c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 37.0624115169381, 1, 1.14408026609731e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 6.05584659721025, 1.3968106840473e-09, 0.95, 0.350885004278312, 0.686696372003195, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.509221366141504, 0.16072099805689, 3.16835617186285, 0.00153303581743651, classic, Inf, 0.194213998390667, 0.82422873389234, 0.178675347905303, , NA, 0.197132683629707, NA, NA, NA, HTS, , NA, 0.462893849380224, 13, 0.95, -0.490799997328941, 1.50924272961195, 0.197132683629707, 0.197132683629707, c(Wald = 37.618748688579, LRT = 48.5537501287027), c(14, 14), c(0.000594190753481038, 1.0640792776045e-05), ML, NULL, , 0.188439476577639, NA, NA, NA, 0.434096160519347, NA, NA, NULL, , , , 1.63922343741042, 1.24072588606055, 2.1657108213381, 0.627845144029196, 0.35039656394325, 0.786794174514572, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.234894125055536, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.05584659721025, 3.16835617186285, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.518790688140753, 0.0856677394007545, 0.350885004278312, 0.686696372003195, 6.05584659721025, 1.3968106840473e-09, 6.05584659721025, Common effect model, common, NA, 0.197132683629707, NA, 1, FALSE, FALSE, list(b = 0.518790688140753, beta = 0.518790688140753, se = 0.0856677394007545, zval = 6.05584659721025, pval = 1.3968106840473e-09, ci.lb = 0.350885004278312, ci.ub = 0.686696372003195, vb = 0.00733896157403559, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 36.6732780089429, QMdf = c(1, NA), QMp = 1.3968106840473e-09, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-90.8130732941009, 48.5537501287027, 213.626146588202, 236.045304694796, 255.472300434356), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000007), list(b = 0.509221366141504, beta = 0.509221366141504, se = 0.16072099805689, zval = 3.16835617186285, pval = 0.00153303581743651, ci.lb = 0.194213998390667, ci.ub = 0.82422873389234, vb = 0.0258312392164028, tau2 = 0.188439476577639, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 57.4593300338307, H2 = 2.3506917046564, vt = 0.139513314495091, QE.Wld = 37.618748688579, QEp.Wld = 0.000594190753481038, QE.LRT = 48.5537501287027, QEp.LRT = 1.0640792776045e-05, QE.df = 14, QM = 10.0384808317814, QMdf = c(1, NA), QMp = 0.0015330358174365, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-73.0465175765165, 13.020638693534, 180.093035153033, 203.91339064129, 231.093035153033), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.640999999999991), 4.2-0, UM.FS
Music
OR	24	11	1.24	1.37	1.513	<.001	.00 [.00, .45]	random	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 6.12619620351618, 9.00048085245428e-10, 0.95, 0.213127522239714, 0.413655119238019, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738951, 0.0511559443992605, 6.12619558526772, 9.00051580728392e-10, classic, Inf, 0.213127512121267, 0.413655129356635, 0.0516471199100862, , NA, 0.0559606871984727, NA, NA, NA, HTS, , NA, 0.0511559443992605, 22, 0.95, 0.207300385386129, 0.419482256091773, 0.0559606871984727, 0.0559606871984727, c(Wald = 21.5987482461991, LRT = 38.9280222931132), c(23, 23), c(0.544572196999553, 0.0202043825060466), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.34362867816388, 0, 0, 0.44608711151508, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 3.86448812170193e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.12619620351618, 6.12619558526772, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 0.213127522239714, 0.413655119238019, 6.12619620351618, 9.00048085245428e-10, 6.12619620351618, Common effect model, common, NA, 0.0559606871984727, NA, 1, FALSE, FALSE, list(b = 0.313391320738867, beta = 0.313391320738867, se = 0.0511559392366495, zval = 6.12619620351618, pval = 9.00048085245428e-10, ci.lb = 0.213127522239714, ci.ub = 0.413655119238019, vb = 0.00261693011918378, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302799239761, QMdf = c(1, NA), QMp = 9.00048085245431e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 25, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926454, 38.9280222931132, 322.753451852909, 369.533477125606, 381.844360943818), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0330000000000155), list(b = 0.313391320738951, beta = 0.313391320738951, se = 0.0511559443992605, zval = 6.12619558526772, pval = 9.00051580728392e-10, ci.lb = 0.213127512121267, ci.ub = 0.413655129356635, vb = 0.00261693064738023, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302723489537, QMdf = c(1, NA), QMp = 9.00051580728395e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 26, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926643, 38.9280222934896, 324.753451853285, 373.40467813689, 391.610594710428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.902999999999963), 4.2-0, UM.FS
OR	24	11	1.24	1.37	1.513	<.001	.00 [.00, .45]	random (all)	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 37.7355752049132, 1, 8.10135636903868e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 24, 24, 24, 24, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 6.12619620351618, 9.00048085245428e-10, 0.95, 0.213127522239714, 0.413655119238019, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738951, 0.0511559443992605, 6.12619558526772, 9.00051580728392e-10, classic, Inf, 0.213127512121267, 0.413655129356635, 0.0516471199100862, , NA, 0.0559606871984727, NA, NA, NA, HTS, , NA, 0.0511559443992605, 22, 0.95, 0.207300385386129, 0.419482256091773, 0.0559606871984727, 0.0559606871984727, c(Wald = 21.5987482461991, LRT = 38.9280222931132), c(23, 23), c(0.544572196999553, 0.0202043825060466), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.34362867816388, 0, 0, 0.44608711151508, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973 ), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 3.86448812170193e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.12619620351618, 6.12619558526772, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.313391320738867, 0.0511559392366495, 0.213127522239714, 0.413655119238019, 6.12619620351618, 9.00048085245428e-10, 6.12619620351618, Common effect model, common, NA, 0.0559606871984727, NA, 1, FALSE, FALSE, list(b = 0.313391320738867, beta = 0.313391320738867, se = 0.0511559392366495, zval = 6.12619620351618, pval = 9.00048085245428e-10, ci.lb = 0.213127522239714, ci.ub = 0.413655119238019, vb = 0.00261693011918378, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302799239761, QMdf = c(1, NA), QMp = 9.00048085245431e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 25, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926454, 38.9280222931132, 322.753451852909, 369.533477125606, 381.844360943818), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999914), list(b = 0.313391320738951, beta = 0.313391320738951, se = 0.0511559443992605, zval = 6.12619558526772, pval = 9.00051580728392e-10, ci.lb = 0.213127512121267, ci.ub = 0.413655129356635, vb = 0.00261693064738023, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0677125283507197, QE.Wld = 21.5987482461991, QEp.Wld = 0.544572196999553, QE.LRT = 38.9280222931132, QEp.LRT = 0.0202043825060466, QE.df = 23, QM = 37.5302723489537, QMdf = c(1, NA), QMp = 9.00051580728395e-10, k = 24, k.f = 24, k.yi = 24, k.eff = 48, k.all = 24, p = 1, p.eff = 25, parms = 26, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879 ), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 5480, 5480, 6101, 6101, 539, 879), ids = 1:24, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:24, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-136.376725926643, 38.9280222934896, 324.753451853285, 373.40467813689, 391.610594710428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.884999999999991), 4.2-0, UM.FS

Excluding Peterson 1977 and Peterson 1983

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000387), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.495000000000005), 4.2-0, UM.FS
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random (all)	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.475000000000023), 4.2-0, UM.FS
Art
OR	17	9	1.38	1.611	1.882	<.001	.59 [.30, .76]	random	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.75200000000001), 4.2-0, UM.FS
OR	17	9	1.379	1.609	1.878	<.001	.59 [.30, .76]	random (all)	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.75), 4.2-0, UM.FS
Music
OR	26	12	1.251	1.38	1.523	<.001	.03 [.00, .45]	random	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0250000000000341), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.07600000000002), 4.2-0, UM.FS
OR	26	12	1.251	1.381	1.524	<.001	.03 [.00, .45]	random (all)	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0230000000000246), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.065), 4.2-0, UM.FS

All methods

All studies, including Cosenza 1993, Peterson 1979, and Peterson 1983.

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	17	9	0.91	1.042	1.193	.55	.20 [.00, .55]	random	GLMM	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.020999999999999), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.482000000000001), 4.2-0, UM.FS
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	Inverse	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, 1.05998403613453, 0.289151861978491, 0.95, -0.061642360556288, 0.20684541370225, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.05998403613453, 1.06369532430366, c(0.406298474663909, 0.789709841459767, 16.9148492202111, 5.70344480193571, 4.05100590830903, 6.29179331306991, 6.00602412872951, 0.915926971958846, 0.955289836236028, 7.74151473195223, 35.6673228567869, 114.370641304911, 0.474640453598307, 0.473093094834541, 0.449787734139478, 0.449644515802929, 11.4997159175123), 0.0726015265729808, 0.0684930377232273, -0.061642360556288, 0.20684541370225, 1.05998403613453, 0.289151861978491, 1.05998403613453, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.899	1.135	1.433	.29	.26 [.00, .59]	random	MH	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 17, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, 0.589363980337228, 0.555617133864833, 0.95, -0.0940868567215518, 0.175002374312089, c(0.397420224983314, 0.756846802013202, 8.76400157528778, 4.34185866076083, 3.31306021363047, 4.67462998160804, 4.51501973513712, 0.872011721060111, 0.907617105749227, 5.430144450972, 12.0452403710558, 15.6919410080138, 0.462568623381939, 0.46109885171634, 0.438932540274245, 0.438796150345121, 7.04512383487973), 0.12663370534577, 0.119050730460501, 1.06369532430366, 0.287466743290939, classic, Inf, -0.106701438689997, 0.359968849381537, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.589363980337228, 1.06369532430366, c(0.58974358974359, 1.44736842105263, 9.21602787456446, 4.83361204013378, 5.04761904761905, 7.04081632653061, 6.46153846153846, 3.25, 0.284090909090909, 6.38524590163934, 33.7032222119045, 117.192002903636, 1.1864159211247, 0.197188241738178, 0.776501476862488, 0.416803413193305, 8.2877094972067), 0.0404577587952687, 0.0686464733934355, -0.0940868567215518, 0.175002374312089, 0.589363980337228, 0.555617133864833, 0.589363980337228, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.815	1.065	1.393	.64	.40 [.00, .66]	random	Peto	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-1.43684210526316, -0.690261338333529, 1.00795306164762, 0.212037275367835, -0.358939974457216, -0.245902766320189, -0.103975776405053, -0.96814727649067, 2.71520154460688, 0.288825505247073, 0.0676634264671485, -0.0375389837855228, -1.15352537697584, -1.02389642850852, -1.24149907767122, -1.11687158278867, 0.510435812545122), c(1.56089219338149, 0.919851510749532, 0.295964545973394, 0.447210581153716, 0.4779292284239, 0.400819752502115, 0.39928626800966, 0.618795351373702, 1.39946633835025, 0.379240441958542, 0.171431799285525, 0.0929909160392439, 0.986041272695215, 2.27870185976276, 1.26445115535852, 1.63695215942607, 0.32406897670339), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), c(0.357297866196262, 0.453010712212803, 0.000660055934616421, 0.635405097974775, 0.452633611523925, 0.539546033178936, 0.794552090065137, 0.117684285849375, 0.052359125243574, 0.446305096005573, 0.693067336878847, 0.686444799637499, 0.242059299632813, 0.653191301938128, 0.326174643421658, 0.495057335302806, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -2.49313717052737, 0.427873210839015, -0.664479357198675, -1.29566404932708, -1.03149504551659, -0.886562481225394, -2.18096387898393, -0.0277020761357525, -0.454472102472721, -0.26833672593738, -0.219797830111829, -3.0861307587285, -5.49007000514796, -3.71977780238397, -4.32523885967883, -0.124727710300273), c(1.62245037751428, 1.11261449386031, 1.58803291245622, 1.08855390793435, 0.577784100412645, 0.539689512876215, 0.678610928415287, 0.244669326002593, 5.45810516534952, 1.03212311296687, 0.403663578871677, 0.144719862540783, 0.779080004776819, 3.44227714813093, 1.23677964704154, 2.09149569410149, 1.14559933539052), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, 0.592961663805544, 0.553206808576661, 0.95, -0.0951582454177123, 0.177711421329491, c(0.395391907150482, 1.06510043053455, 5.54487213854294, 3.41589434911937, 3.11363383013073, 3.94620110640505, 3.96540075258979, 2.10234428946293, 0.487505756565418, 4.22698736188081, 8.18728184765695, 9.86201973008252, 0.938941402440821, 0.189206382731604, 0.591160313115281, 0.360702973669442, 5.05631473520319), 0.0630490798536173, 0.13678244836612, 0.460944226446775, 0.644838620359311, classic, Inf, -0.205039592661188, 0.331137752368423, 0.13678244836612, , NA, 0.143767123196811, NA, NA, NA, HTS, , NA, 0.333858106594923, 15, 0.95, -0.648552629729578, 0.774650789436813, 0.143767123196811, 0.143767123196811, 26.4821853167165, 16, 0.047609917873651, REML, NULL, QP, 0.0927517971581165, 0.0891761562969764, 0, 1.08061331145796, 0.304551797167767, 0, 1.03952552227348, NULL, , , , 1.28652111614803, 1, 1.71725833898097, 0.395820253931225, 0, 0.660899264276656, 0.291616884234202, 0, 0.613097971938004, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0927517971581165, m4 = NULL), c(-0.920526165327543, -0.750405179821987, 3.40565474939768, 0.474132957276683, -0.751031644666129, -0.613499621176707, -0.260404087832387, -1.56456779182555, 1.94016924180376, 0.761589412129858, 0.39469588926412, -0.403684417622906, -1.16985506481167, -0.449333213172134, -0.981848189556368, -0.682287247282936, 1.57508385325112), FALSE, 0.592961663805544, 0.460944226446775, c(0.410444256598103, 1.18185595567867, 11.4161750967902, 5.00006740351252, 4.37797036622868, 6.2244612689918, 6.27236396391824, 2.61159552095632, 0.510593270365998, 6.95297570619181, 34.0264963846463, 115.642893123005, 1.02851306508322, 0.192586121259762, 0.6254547351892, 0.373188305277323, 9.5219321922109), 0.0412765879558895, 0.0696108879804845, -0.0951582454177123, 0.177711421329491, 0.592961663805544, 0.553206808576661, 0.592961663805544, Common effect model, common, NA, 0.143767123196811, NA, 1, FALSE, FALSE
OR	17	9	0.854	1.101	1.42	.46	.26 [.00, .59]	random	SSW	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, 1.20554350941747, 0.227993552034675, 0.95, -0.0602854100327486, 0.252954318616497, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.129638051538024, 0.743103225858177, 0.457419186766786, classic, Inf, -0.1577514577486, 0.350420366332349, 0.119050730460501, , NA, 0.112454889390565, NA, NA, NA, HTS, , NA, 0.262976335689908, 15, 0.95, -0.433887085853459, 0.687154496544999, 0.112454889390565, 0.112454889390565, 21.5773657885352, 16, 0.157369509366594, REML, NULL, QP, 0.0549834767097123, 0.0633244677386035, 0, 0.505119219763635, 0.234485557571703, 0, 0.710717397960424, NULL, , , , 1.16128608093934, 1, 1.55608020440601, 0.258482237507352, 0, 0.587013320410734, 0.228201842904439, 0, 0.589316954089921, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0549834767097123, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 1.20554350941747, 0.743103225858177, c(16.2179487179487, 16.0394736842105, 123.682055749129, 129.685618729097, 35.5102040816327, 35.5102040816327, 57.6521739130435, 22.8579545454545, 22.8579545454545, 55.9918032786885, 335.818924691243, 509.26320246809, 8.98521088186964, 8.98521088186964, 3.99737446668855, 3.99737446668855, 116.819832402235), 0.0963344542918742, 0.0799095624001361, -0.0602854100327486, 0.252954318616497, 1.20554350941747, 0.227993552034675, 1.20554350941747, Common effect model, common, NA, 0.112454889390565, NA, 1, FALSE, FALSE
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0220000000000198), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.47399999999999), 4.2-0, UM.FS
OR	17	9	0.914	1.044	1.193	.53	.20 [.00, .55]	random (all)	glmer	c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.35192518928595, 1, 0.553025345115509, FALSE, c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), c(0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), OR, 0, c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.1983090846914, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182624, -0.0377462839473047, -1.06199361583117, 0.848482694649035, -0.774936080139642, -0.0472571148705747, 0.46149942111032), c(1.5688354854077, 1.1252945742284, 0.243145331083503, 0.418727398196639, 0.49684229786825, 0.398669284078461, 0.408043499640472, 1.04488760145009, 1.02313377477651, 0.359407410726177, 0.167442131374939, 0.0935066981738867, 1.4515019540099, 1.4538737501552, 1.49106369527854, 1.4913011391401, 0.294887554610119), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), c(0.616025698505328, 0.461156259021663, 0.000860464704901891, 0.63578553504354, 0.452833053467925, 0.53865271084865, 0.794287372697252, 0.149782462242316, 0.0833625150007686, 0.446737306426713, 0.693104702687077, 0.686451980980324, 0.464381291726889, 0.559488546463854, 0.603258531721447, 0.97472045594073, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -3.03481619237053, 0.33374380595198, -0.622381535114174, -1.34677266278157, -1.02649989656914, -0.906146811952367, -3.55289397165582, -0.233748588017944, -0.430964821071397, -0.262100302671242, -0.22101604468138, -3.90688516918009, -2.00105749372333, -3.6973672215408, -2.97015363768873, -0.1164695654146), c(2.28810436938525, 1.37625748260147, 1.28685598981745, 1.01899970449697, 0.600813356854215, 0.536254980503167, 0.69335431488965, 0.542990161813405, 3.77686211183901, 0.977886340528807, 0.394260791307767, 0.14552347678677, 1.78289793751774, 3.6980228830214, 2.14749506126151, 2.87563940794759, 1.03946840763524), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, 0.593200969842303, 0.553046663658635, 0.95, -0.0944310062275479, 0.176400687693875, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331634, 0.0690909882616123, 0.59320096244643, 0.553046668607643, classic, Inf, -0.0944310079158763, 0.176400689382203, 0.109769573210252, , NA, 0.107801181593611, NA, NA, NA, HTS, , NA, 0.0690909882616123, 15, 0.95, -0.106279114799326, 0.188248796265653, 0.107801181593611, 0.107801181593611, c(Wald = 20.0476284700347, LRT = 27.4867301799309), c(16, 16), c(0.218083137464584, 0.0363800511642976), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.11936445332929, 1, 1.49468881310209, 0.201900612637786, 0, 0.552391390002385, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 7, 12, 13, 14, 16, 18, 19, 20, 29, 36, 39, 41, 44, 47, 50, 54), study = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architecture", "Architects", "Architects", "Architecture (freshmen)", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Law, Psychology", "Non-architects", "Non-architects", "HS seniors", "HS seniors", "General students (M)", "General students (W)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "1i_3pt", "1i_3pt", "4i_3pt", "4i_3pt", "0-split", "Writing hand", "Writing hand", "0-split", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "Drawing hand"), rl_sm = c("S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L"), n_creative = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n_left_creative = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), n_right_creative = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), n_control = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), n_left_control = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n_right_control = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), PL_creative = c(0, 4.34782608695652, 18.4397163120567, 4.72972972972973, 11.6666666666667, 75, 11.5384615384615, 3.7037037037037, 7.40740740740741, 17.3913043478261, 12.1037463976945, 34.0304182509506, 0, 0, 0, 0, 12.2448979591837), PL_control = c(3.63636363636364, 9.43396226415094, 9.13604766633565, 3.91221374045802, 16.0919540229885, 79.3103448275862, 12.6696832579186, 14.7651006711409, 1.34228187919463, 13.8047138047138, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.0639485041028121, 1.39958965745661, 0.54736012451512, 0.266371689248105, 0.360201254064835, 0.410096960522666, 0.0366109225183829, 0.985202592325505, 0.656029435454098, 0.770193102766583, 0.801706664455788, 0, 0, 0, 0, 0.89532149083073), effect = c(0, 0.436363636363636, 2.24858223062382, 1.21933921466874, 0.688679245283019, 0.782608695652174, 0.899068322981367, 0.222027972027972, 5.88, 1.31450577663671, 1.06831243972999, 0.962957227606861, 0, 0, 0, 0, 1.58645096056623), upper = c(4.73704496995417, 3.0959628184797, 3.61257460066216, 2.71900498756244, 1.78764893600914, 1.69867400265703, 1.97499953274194, 1.36956935286763, 35.1639182075498, 2.63918495427251, 1.48182509656637, 1.15664078061488, 2.81240464682898, 19.1649004245487, 3.99113580499188, 8.27063753472762, 2.81389813908544), chi_sq = c(0.02, 0.09, 10.62, 0.06, 0.26, 0.17, 0, 1.58, 1.55, 0.33, 0.1, 0.13, 0.46, 0, 0.12, 0, 2), p = c(0.887880413534634, 0.769973513794959, 0.00111769317670308, 0.802098276857206, 0.607379457302083, 0.678506486761815, 0.951468462772894, 0.208120208893935, 0.213508717330893, 0.566812505144001, 0.757325835037076, 0.720942262780942, 0.498471798968014, 0.999999999999994, 0.726600405319471, 0.999999999999984, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L"), pref_success = c("mix", "mix", "success", "success", "pref", "pref", "pref", "pref", "pref", "pref", "preference", "preference", "mix", "mix", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.773487252391632, 0.564547348997558, 0.55400121639402, 0.388088061505383, 0.341453404029332, 0.399217175561138, 0.340046664342675, 8.71922032364412, 0.505916316437775, 0.181542109807387, 0.090546081193013, 0.717463348564788, 4.88909504861288, 1.01816559806034, 2.10989528378209, 0.489441812040476), inv_var = c(0.684764375218916, 1.67145111298491, 3.13761212946032, 3.25820618247439, 6.63956204965919, 8.57703350673165, 6.27453526571943, 8.64814498587693, 0.0131536019805634, 3.90699295075821, 30.3420726125208, 121.972150834508, 1.94267682668582, 0.0418353145911693, 0.964635325792623, 0.224635400028762, 4.17443655632658 ), .event.e = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), .n.e = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), .event.c = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), .n.c = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), .studlab = c("shettel-neuber_1983", "shettel-neuber_1983", "schacter_1996", "schacter_1996", "gotestam_1990", "gotestam_1990", "wood_1991", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0388064039361684, m4 = NULL), c(-0.501490874601039, -0.736944240092112, 3.33257436724719, 0.473599495866453, -0.750700281686929, -0.614851627206732, -0.260747318913558, -1.4403002799848, 1.73150061662025, 0.760865668229215, 0.394645265057541, -0.403674653093953, -0.731651523373652, 0.583601357792218, -0.519720306109979, -0.0316885125547638, 1.56500135016035), FALSE, 0.593200969842303, 0.59320096244643, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.0409848407331637, 0.0690909874002046, -0.0944310062275479, 0.176400687693875, 0.593200969842303, 0.553046663658635, 0.593200969842303, Common effect model, common, NA, 0.107801181593611, NA, 1, FALSE, FALSE, list(b = 0.0409848407331637, beta = 0.0409848407331637, se = 0.0690909874002046, zval = 0.593200969842303, pval = 0.553046663658635, ci.lb = -0.0944310062275479, ci.ub = 0.176400687693875, vb = 0.00477356453993523, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887390621849, QMdf = c(1, NA), QMp = 0.553046663658635, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141962558, 27.4867301799309, 211.868028392512, 239.342517835603, 257.468028392512), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999914), list(b = 0.0409848407331634, beta = 0.0409848407331634, se = 0.0690909882616123, zval = 0.59320096244643, pval = 0.553046668607643, ci.lb = -0.0944310079158763, ci.ub = 0.176400689382203, vb = 0.00477356465896625, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.111901239898097, QE.Wld = 20.0476284700347, QEp.Wld = 0.218083137464584, QE.LRT = 27.4867301799309, QEp.LRT = 0.0363800511642976, QE.df = 16, QM = 0.351887381847371, QMdf = c(1, NA), QMp = 0.553046668607643, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321 ), vi = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, -0.829279354884525, 0.810299897884713, 0.198309084691399, -0.372979652963676, -0.245122458032985, -0.106396248531358, -1.50495190492121, 1.77155676191054, 0.273460759728705, 0.0660802443182626, -0.0377462839473048, -1.06199361583117, 0.848482694649036, -0.774936080139642, -0.0472571148705745, 0.461499421110321), vi.f = c(2.46124478027441, 1.26628787878788, 0.0591196520277062, 0.175332634000526, 0.246852268951002, 0.158937198067633, 0.166499497598844, 1.09179009966412, 1.04680272108844, 0.129173686884895, 0.0280368673593823, 0.00874350260338234, 2.10685792249455, 2.11374888139033, 2.22327094337771, 2.22397908760057, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ti = NA), outdat = list(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), bi = c(23, 22, 115, 141, 53, 15, 69, 26, 25, 57, 305, 347, 9, 9, 4, 4, 129), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), di = c(53, 48, 915, 1007, 73, 18, 193, 127, 147, 256, 9232, 10422, 4746, 5348, 4907, 5455, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ni.f = c(78, 76, 1148, 1196, 147, 147, 299, 176, 176, 366, 10769, 16531, 5477, 5477, 6094, 6094, 716), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-87.9340141964709, 27.486730180361, 213.868028392942, 242.868878360649, 268.153742678656), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 1, 26, 7, 7, 45, 9, 1, 2, 12, 42, 179, 0, 0, 0, 0, 18), ci = c(2, 5, 92, 41, 14, 69, 28, 22, 2, 41, 1190, 5583, 722, 120, 1183, 635, 46), n1i = c(23, 23, 141, 148, 60, 60, 78, 27, 27, 69, 347, 526, 9, 9, 4, 4, 147), n2i = c(55, 53, 1007, 1048, 87, 87, 221, 149, 149, 297, 10422, 16005, 5468, 5468, 6090, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.473000000000013), 4.2-0, UM.FS
Art
OR	17	9	1.247	1.598	2.048	<.001	.59 [.30, .76]	random	GLMM	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999996), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.766), 4.2-0, UM.FS
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	Inverse	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 5.59787281727964, 2.16997844692742e-08, 0.95, 0.314512352102863, 0.653406431727379, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.59787281727964, 2.88818727880593, c(4.5115576371053, 7.85285677015393, 0.644246353322528, 0.796612109419709, 0.410268156712951, 1.51141868512111, 3.4723947319704, 12.1163464079305, 1.90119132548178, 0.96868264232281, 14.1584667671487, 7.85178901280589, 11.4997159175123, 4.55123826988389, 35.6012311658001, 12.1828226441155, 13.7605648851838), 0.483959391915121, 0.0864541599482618, 0.314512352102863, 0.653406431727379, 5.59787281727964, 2.16997844692742e-08, 5.59787281727964, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.164	1.604	2.211	.004	.61 [.33, .77]	random	MH	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 16, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 6.03879245958711, 1.55271798516199e-09, 0.95, 0.335531503617244, 0.657991576057912, c(2.23718129403058, 2.83542915003842, 0.562575445721107, 0.675377141587339, 0.375549007909623, 1.12743620853956, 1.94808813358655, 3.24811116056221, 1.33098353450022, 0.795122433328953, 3.37875252105257, 2.83528993294986, 3.20208236773686, 2.24689548321327, 3.94590912432035, 3.25286937846709, 3.35559725802799), 0.472564568054066, 0.16361978031059, 2.88818727880593, 0.0038746909939709, classic, Inf, 0.151875691486955, 0.793253444621178, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 6.03879245958711, 2.88818727880593, c(2.34782608695652, 5.51470588235294, 0.697674418604651, 1.74698795180723, 0, 0.646153846153846, 3.07375872955132, 10.7793348281016, 5.37143894030122, 0.914534567229178, 11.3237153509483, 7.11363267952667, 8.2877094972067, 4.35992578849722, 29.1240045506257, 10.9219712525667, 6.72689938398357), 0.496761539837578, 0.082261734140064, 0.335531503617244, 0.657991576057912, 6.03879245958711, 1.55271798516199e-09, 6.03879245958711, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.152	1.596	2.212	.005	.65 [.42, .79]	random	Peto	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.37380660954712, 0.737734224795348, -0.12052903696899, -0.898720357210923, 2.88135593220339, 1.886625, 0.146763960036387, 0.190703412437214, -0.749367968408782, 0.0609904207495266, 0.313395219413491, 0.117134174635773, 0.510435812545122, 0.0562064185176206, 0.371336934921835, 0.213083622484386, 1.50046978291384), c(0.415528842183368, 0.342493017102583, 1.21687522422527, 0.876931092336367, 1.48876715444574, 0.673934343983151, 0.565457624206178, 0.294238027642615, 0.453165389135724, 1.04464964727608, 0.287580331760914, 0.372381982228678, 0.32406897670339, 0.475482940518229, 0.17013786477182, 0.286867912404376, 0.233931487850484), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), c(0.000945826213271411, 0.0312391951359797, 0.921100172165413, 0.305435300635845, 0.0529415602967437, 0.00511945666092442, 0.795211681566248, 0.51690324668251, 0.0982026747675452, 0.953443067420015, 0.275816308736864, 0.753100447472451, 0.115237090566695, 0.905901966336454, 0.0290678656470361, 0.457606707594208, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, 0.0664602463178242, -2.50556065012963, -2.61747371511357, -0.0365740718764318, 0.565737957848396, -0.961512618191306, -0.385992524624412, -1.63755581015488, -1.98648526437405, -0.250251873499981, -0.61272109902407, -0.124727710300273, -0.87572302016131, 0.0378728475625207, -0.349167154148383, 1.04197249187702), c(2.18822817476415, 1.40900820327287, 2.26450257619165, 0.820033000691724, 5.79928593628321, 3.2075120421516, 1.25504053826408, 0.767399349498841, 0.138819873337315, 2.10846610587311, 0.877042312326963, 0.846989448295615, 1.14559933539052, 0.988135857196551, 0.704801022281149, 0.775334399117154, 1.95896707395066), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 5.97515138157933, 2.29876620951754e-09, 0.95, 0.342256498088733, 0.676393036883093, c(2.34039020582257, 2.68877611668498, 0.576235936882886, 0.976922073540483, 0.404687479201077, 1.41083032215136, 1.74107655668937, 2.93090988293862, 2.17403673768121, 0.742992921004605, 2.96456685862538, 2.54269633016767, 2.78059189475238, 2.08030395739873, 3.52656747293488, 2.96816796823362, 3.23270045758165), 0.467416470190684, 0.166476130078398, 2.80770864850454, 0.00498953457085751, classic, Inf, 0.141129250951419, 0.793703689429949, 0.166476130078398, , NA, 0.174105471348229, NA, NA, NA, HTS, , NA, 0.531346647463955, 15, 0.95, -0.665122100081072, 1.59995504046244, 0.174105471348229, 0.174105471348229, 45.9739733189945, 16, 9.82687632317443e-05, REML, NULL, QP, 0.254614957885305, 0.153865974531026, 0.0732916386525852, 1.2351123835785, 0.504593854387174, 0.270724285302566, 1.11135610115683, NULL, , , , 1.695102749817, 1.31064081974728, 2.19234231770012, 0.651977002531789, 0.417853058300504, 0.791942552488268, 0.540419546756557, 0.298042011584244, 0.78279708192887, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.254614957885305, m4 = NULL), c(3.30616426606767, 2.15401245560105, -0.0990479833671733, -1.02484718020033, 1.93539730077946, 2.79941958269924, 0.259548998463718, 0.648126328078997, -1.65363018971501, 0.0583836130214174, 1.08976583167043, 0.314553818997186, 1.57508385325112, 0.118209116937741, 2.18256491827878, 0.74279350624624, 6.41414200670948), FALSE, 5.97515138157933, 2.80770864850454, c(5.79158790170132, 8.52504258972014, 0.675317341647313, 1.30037635112888, 0.451176470588235, 2.20173386541902, 3.1275183875337, 11.5505429295484, 4.86952426469657, 0.916344285972613, 12.0915406214237, 7.2114514029265, 9.5219321922109, 4.42313424124118, 34.5460218820105, 12.151672436111, 18.2735377164244), 0.509324767485913, 0.0852404792715545, 0.342256498088733, 0.676393036883093, 5.97515138157933, 2.29876620951754e-09, 5.97515138157933, Common effect model, common, NA, 0.174105471348229, NA, 1, FALSE, FALSE
OR	17	9	1.156	1.624	2.279	.005	.61 [.33, .77]	random	SSW	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 4.45245214061084, 8.48951664069714e-06, 0.95, 0.271291286301498, 0.697950204760471, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.173122829486191, 2.79928849920766, 0.00512153558728871, classic, Inf, 0.145306234836381, 0.823935256225589, 0.16361978031059, , NA, 0.173106915378884, NA, NA, NA, HTS, , NA, 0.50210510719032, 15, 0.95, -0.597647134489983, 1.54277627059812, 0.173106915378884, 0.173106915378884, 40.5591649675437, 16, 0.000644794600412751, REML, NULL, QP, 0.225338106157717, 0.145244903613736, 0.0560550950569602, 1.25821837270949, 0.474697910420635, 0.236759572260469, 1.12170333542764, NULL, , , , 1.5921519432741, 1.22141291328969, 2.07542247416068, 0.605514560943167, 0.329691100331837, 0.767840227535541, 0.49512414812918, 0.235616420628732, 0.754631875629628, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.225338106157717, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 4.45245214061084, 2.79928849920766, c(40.0621118012422, 50.9950980392157, 19.8255813953488, 19.1566265060241, 27.3, 30.7692307692308, 30.9080646704295, 50.8380044843049, 42.6644892034114, 42.6644892034114, 77.0137785702707, 77.0137785702707, 116.819832402235, 81.4471243042672, 145.483503981797, 121.047227926078, 121.047227926078), 0.484620745530985, 0.108843560857343, 0.271291286301498, 0.697950204760471, 4.45245214061084, 8.48951664069714e-06, 4.45245214061084, Common effect model, common, NA, 0.173106915378884, NA, 1, FALSE, FALSE
OR	17	9	1.38	1.611	1.882	<.001	.59 [.30, .76]	random	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999866), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.75800000000001), 4.2-0, UM.FS
OR	17	9	1.379	1.609	1.878	<.001	.59 [.30, .76]	random (all)	glmer	c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 35.7675238836973, 1, 2.22323181106671e-09, FALSE, c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), OR, 0, c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.112207407666009, 0.46149942111032, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), c(0.470800315253516, 0.356850378577675, 1.24587369257948, 1.12040889498166, 1.56122714924122, 0.813406439997887, 0.536642983800502, 0.287285799440795, 0.725248915341631, 1.01603633937568, 0.265761390325417, 0.356874641625254, 0.294887554610119, 0.468743451662213, 0.167597482775787, 0.28650093199192, 0.269576399645543), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), c(0.00168015444713672, 0.0329588476609907, 0.920685071461201, 0.323778667974397, 0.145731501633408, 0.0136878532708386, 0.795362990483667, 0.517488118168704, 0.11681605252122, 0.953445650782195, 0.277397618027478, 0.753204445245946, 0.117582592730875, 0.905825755999269, 0.0294321382277291, 0.457736915067221, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, 0.0615996019084648, -2.56592021541169, -3.30149381363506, -0.788714421088967, 0.411086242337315, -0.912621023047227, -0.377132060946112, -2.55885434193782, -1.93207805500383, -0.232216997612435, -0.587254036915127, -0.1164695654146, -0.863265447331764, 0.0364835513107171, -0.348782078664277, 1.09616495872771), c(2.40182775637785, 1.46042738167192, 2.31781491807173, 1.09042835060969, 5.33118354730891, 3.59958089671491, 1.19098081856296, 0.7490075794014, 0.284069165854855, 2.05071120931667, 0.809548509425781, 0.811668852247145, 1.03946840763524, 0.974175119162093, 0.693453611590945, 0.774280937818367, 2.15288502750219), FALSE, NULL, 17, 17, 17, 17, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 5.9512421861131, 2.6611495795586e-09, 0.95, 0.3231478902864, 0.640519015351962, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.468849192819182, 0.126537122921541, 3.70523038610489, 0.000211198677793007, classic, Inf, 0.220840989185644, 0.716857396452719, 0.155940674684545, , NA, 0.17053971056971, NA, NA, NA, HTS, , NA, 0.347035319320937, 15, 0.95, -0.270839080840621, 1.20853746647898, 0.17053971056971, 0.17053971056971, c(Wald = 39.2445929431571, LRT = 50.2625101269437), c(16, 16), c(0.00100259033734452, 2.08184538552299e-05), ML, NULL, , 0.104421869378924, NA, NA, NA, 0.323143728670268, NA, NA, NULL, , , , 1.56613762452325, 1.19900576868772, 2.04568411846077, 0.592300523458739, 0.30440339317296, 0.761041296721926, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 3, 4, 6, 9, 11, 35, 38, 42, 45, 48, 51, 53, 55, 57, 59, 60), study = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Students", "Faculty", "Faculty", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Military", "Military", "Students", "Students"), group1 = c("Art", "Art", "Art", "Art", "Writers, Painters", "Writers, Painters", "Fine Arts applicants", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Art Hobbies", "Science/Visual Art", "Science/Visual Art"), group2 = c("Non-Art", "Non-Art", "Law, Psychology", "Law, Psychology", "Noncreatives", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Non-Art Hobbies", "Lang/Lit", "Lang/Lit"), h = c("HPQ", "HPQ", "1i_3pt", "1i_3pt", "AHQ", "AHQ", "EHI", "EHI", "2i_2pt", "2i_2pt", "4i_3pt", "4i_3pt", "Drawing hand", "AHQ", "AHQ", "13i_3pt", "13i_3pt"), rl_sm = c("R/L", "S/M", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "S/M", "R/L", "S/M"), n_creative = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n_left_creative = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), n_right_creative = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), n_control = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), n_left_control = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n_right_control = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), PL_creative = c(28, 27.1844660194175, 3.2258064516129, 3.33333333333333, 4.76190476190476, 16, 12.9032258064516, 39.2156862745098, 4.65116279069767, 2.32558139534884, 24.3589743589744, 11.5384615384615, 12.2448979591837, 6, 45.6521739130435, 12.4444444444444, 30.6666666666667), PL_control = c(8.13953488372093, 14.8514851485149, 3.63636363636364, 9.43396226415094, 0, 2.5, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4385158430471, 10.4416351994746, 8.08435852372583, 5.69476082004556, 36.8345323741007, 10.3053435114504, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 1.06929827167943, 0.110651241887946, 0.0489021206257103, 0.974358001722383, 1.67987422756774, 0.419088323016755, 0.690636202130481, 0.0853419904948197, 0.1830194849695, 0.796574942631189, 0.562813498592441, 0.89532149083073, 0.433242739236992, 1.03745938361973, 0.708695088055667, 3.00245314669162), effect = c(4.38888888888889, 2.14044444444444, 0.883333333333333, 0.331034482758621, Inf, 7.42857142857143, 1.14933084344849, 1.20434729853877, 0.320654009864198, 1.06111111111111, 1.33464555657352, 1.1187448728466, 1.58645096056623, 1.05702127659574, 1.44046875, 1.23707463808987, 5.07600732600733), upper = c(10.8155297724311, 4.28030757692179, 7.17252817670378, 2.31371177621804, Inf, 32.3610554643716, 3.15514004201175, 2.10016852725539, 1.20478785936251, 6.16442467777959, 2.2361722247974, 2.22380965213288, 2.81389813908544, 2.58665434552118, 2.00003031683707, 2.15939645412777, 8.58159948376588), chi_sq = c(9.66, 3.95, 0, 0.35, 1.43, 6.11, 0, 0.25, 2.04, 0, 0.9, 0.02, 2, 0, 4.4, 0.36, 39.74), p = c(0.00188315203416169, 0.0468511198471503, 0.999999999999999, 0.555226654080462, 0.231693626958297, 0.0134367644268677, 0.999999999999998, 0.616354994623377, 0.153528886490197, 0.999999999999885, 0.34412188746252, 0.897853612835423, 0.15735099029876, 0.999999999999999, 0.0358442262031739, 0.548522324881787, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "SR/SL", "(SR+SL)/M", "0 split", "SR/(M+SL)"), pref_success = c("preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.819150078922469, 1.80153232164443, 0.577768181828048, Inf, 7.82697577068077, 0.697985202936539, 0.359581180124512, 0.285578173297504, 1.52589671034536, 0.367250952956679, 0.423731294718211, 0.489441812040476, 0.549349789911963, 0.245558321686005, 0.370083679474482, 1.42327776966359 ), inv_var = c(0.18788448346753, 1.49029774780901, 0.308117158028698, 2.99566163549202, 0, 0.016323452551479, 2.05261533117729, 7.7340342886758, 12.2616799854792, 0.429486706960766, 7.4143679914957, 5.56953477459766, 4.17443655632658, 3.31361520572076, 16.5840533845998, 7.30129899135206, 0.493651735043577), .event.e = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), .n.e = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), .event.c = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), .n.c = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), .studlab = c("mebert_1980", "mebert_1980", "shettel-neuber_1983", "shettel-neuber_1983", "preti_2007", "preti_2007", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "peterson_1979", "giotakos_2004", "giotakos_2004", "coren_1982", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.192780169581867, m4 = NULL), c(3.14162086695801, 2.13258423550906, -0.0995708067429674, -0.986722558580527, 1.45477521590232, 2.46535246208688, 0.259352869522669, 0.647222242065476, -1.56827892325176, 0.0583803697344796, 1.08618394701055, 0.314416869618424, 1.56500135016035, 0.118305302652264, 2.17764954106792, 0.742578490401021, 6.02621370138851), FALSE, 5.9512421861131, 3.70523038610489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.481833452819181, 0.0809635094238835, 0.3231478902864, 0.640519015351962, 5.9512421861131, 2.6611495795586e-09, 5.9512421861131, Common effect model, common, NA, 0.17053971056971, NA, 1, FALSE, FALSE, list(b = 0.481833452819181, beta = 0.481833452819181, se = 0.0809635094238835, zval = 5.9512421861131, pval = 2.6611495795586e-09, ci.lb = 0.3231478902864, ci.ub = 0.640519015351962, vb = 0.00655508985823128, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 35.4172835577722, QMdf = c(1, NA), QMp = 2.66114957955862e-09, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 18, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534 ), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:17, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-104.822206772527, 50.2625101269437, 245.644413545054, 273.118902988145, 291.244413545054), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.019999999999996), list(b = 0.468849192819182, beta = 0.468849192819182, se = 0.126537122921541, zval = 3.70523038610489, pval = 0.000211198677793007, ci.lb = 0.220840989185644, ci.ub = 0.716857396452719, vb = 0.0160116434772611, tau2 = 0.104421869378924, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 43.26171152681, H2 = 1.76247826099393, vt = 0.136950618425244, QE.Wld = 39.2445929431571, QEp.Wld = 0.00100259033734452, QE.LRT = 50.2625101269437, QEp.LRT = 2.08184538552299e-05, QE.df = 16, QM = 13.728732214115, QMdf = c(1, NA), QMp = 0.000211198677793007, k = 17, k.f = 17, k.yi = 17, k.eff = 34, k.all = 17, p = 1, p.eff = 18, parms = 19, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, 0.761013491790191, -0.124052648669979, -1.10553273151268, 2.27123456310997, 2.00533356952611, 0.139179897757867, 0.185937759227644, -1.13739258804148, 0.0593165771564195, 0.288665755906673, 0.11220740766601, 0.461499421110321, 0.0554548359151648, 0.364968581450831, 0.212749429577045, 1.62452499311495), vi.f = c(0.22165293684281, 0.12734219269103, 1.55220125786164, 1.25531609195402, 2.43743021152788, 0.661630036630037, 0.287985692062305, 0.082533130560337, 0.525985989204212, 1.03232984293194, 0.0706291165876984, 0.127359509835153, 0.0869586698639356, 0.219720423476205, 0.0280889162327801, 0.0820827840322386, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ti = NA), outdat = list(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), bi = c(54, 75, 30, 29, 40, 42, 27, 31, 41, 42, 59, 69, 129, 94, 100, 197, 156), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), di = c(79, 86, 53, 48, 78, 78, 9232, 10422, 4746, 5348, 4907, 5455, 523, 414, 439, 235, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ni.f = c(161, 204, 86, 83, 120, 130, 10453, 16056, 5511, 5511, 6169, 6169, 716, 539, 879, 487, 487), ids = 1:17, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE ), slab = 1:17, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-89.0802090621481, 18.7785147061856, 216.160418124296, 245.161268092003, 270.446132410011), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 28, 1, 1, 2, 8, 4, 20, 2, 1, 19, 9, 18, 6, 84, 28, 69), ci = c(7, 15, 2, 5, 0, 2, 1190, 5583, 722, 120, 1184, 636, 46, 25, 256, 27, 21), n1i = c(75, 103, 31, 30, 42, 50, 31, 51, 43, 43, 78, 78, 147, 100, 184, 225, 225), n2i = c(86, 101, 55, 53, 78, 80, 10422, 16005, 5468, 5468, 6091, 6091, 569, 439, 695, 262, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.747), 4.2-0, UM.FS
Music
OR	26	12	1.248	1.379	1.524	<.001	.03 [.00, .45]	random	GLMM	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.253), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.126), 4.2-0, UM.FS
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	Inverse	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 6.60558972822383, 3.95938005018008e-11, 0.95, 0.238851716327093, 0.440392170713961, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.60558972822383, 6.60513910530831, c(5.22170527252517, 0.427776590548296, 0.953711790393013, 5.70178701197636, 7.75727875468434, 42.6480889422454, 25.2338741832611, 41.4641170604007, 54.4338335603833, 33.9413143969245, 51.1516656971336, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 17.8489889716194, 19.8068303314417, 0.999052244068159, 2.39841666483754, 0.480400900793124, 0.478815817963196, 0.908224711205891, 0.478763628445952, 4.55123826988389, 35.6012311658001), 0.339621943520527, 0.0514143259714447, 0.238851716327093, 0.440392170713961, 6.60558972822383, 3.95938005018008e-11, 6.60558972822383, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.27	1.404	1.553	<.001	.20 [.00, .50]	random	MH	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 25, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 6.32363599960205, 2.55479143069901e-10, 0.95, 0.222522173794433, 0.422415953571305, c(5.22162450724948, 0.427776048497277, 0.953709096131404, 5.70169071307505, 7.75710051044491, 42.6427018926239, 25.2319881815071, 41.4590249455287, 54.4250580070891, 33.9379023080223, 51.1439164332721, 2.52340970952709, 4.32117669921905, 10.7589327960658, 5.53886768429235, 2.66593105564615, 17.8480453215684, 19.8056683179528, 0.999049287541492, 2.39839962549368, 0.480400217174801, 0.478815138848625, 0.908222267819525, 0.478762949479416, 4.55117691346882, 35.5974771947082), 0.339616342322129, 0.0514169856088559, 6.60513910530831, 3.97144254569851e-11, classic, Inf, 0.238840902335157, 0.4403917823091, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.32363599960205, 6.60513910530831, c(2.98701298701299, 0, 0.509090909090909, 6, 9.06857142857143, 32.6529384544192, 20.3611556982343, 31.064561734213, 40.7445627024526, 25.2279293739968, 39.1837888784166, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 20.314629258517, 14.3518518518519, 0.228275465183196, 1.39444270995941, 1.58102189781022, 0.262773722627737, 1.93902638911654, 1.14489427962629, 4.35992578849722, 29.1240045506257), 0.322469063682869, 0.0509942481988467, 0.222522173794433, 0.422415953571305, 6.32363599960205, 2.55479143069901e-10, 6.32363599960205, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.2	1.367	1.558	<.001	.43 [.09, .64]	random	Peto	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, 1.17826257861635, -0.100526663026663, -0.301878909223286, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.490670728524915, 0.452618839163683, 0.441543762495517, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, -0.172032692354803, 0.516686677945751, 3.80987443815582, 1.10546580074985, -1.15406139984312, -1.02444480232342, -0.660637623336967, -1.11800549988975, 0.0562064185176206, 0.371336934921835), c(0.540780565579624, 1.32219331813667, 1.13845897443781, 0.417348609294271, 0.355932285189848, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 0.22726902886927, 0.244167347549023, 1.57151003840543, 0.663625553755456, 0.854369065122966, 1.97448261801463, 0.763018377649432, 0.988187320844407, 0.475482940518229, 0.17013786477182), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), c(0.10990091605911, 0.00351376944795559, 0.300686329135404, 0.809656053389246, 0.396362352687967, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.449076125152964, 0.0343348569588449, 0.0153362452313665, 0.0957537505474681, 0.176767133978651, 0.603870823550084, 0.386588123690052, 0.257899388302445, 0.905901966336454, 0.0290678656470361 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -1.05307600915816, -0.918514906241311, -0.999493369130427, 0.126119628474816, -0.109459222670617, 0.15271233326912, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, -0.617471803739965, 0.0381274705489931, 0.729771361538017, -0.195216383831291, -2.82859399698928, -4.89435962173246, -2.15612616307204, -3.05481705872391, -0.87572302016131, 0.0378728475625207 ), c(1.92442314671454, 6.45067458511826, 3.40960116639086, 0.717461580187986, 0.395735550683856, 0.761269452833273, 0.727504996658277, 0.801769440950646, 0.771661460016443, 0.820306387820303, 0.731535599651959, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 0.273406419030359, 0.995245885342509, 6.88997751477362, 2.406147985331, 0.520471197303052, 2.84547001708561, 0.834850916398102, 0.818806058944414, 0.988135857196551, 0.704801022281149), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 6.3335201530061, 2.39629990758453e-10, 0.95, 0.234363564503757, 0.444418781824495, c(3.2056225603369, 0.565705751325006, 0.760111130549942, 5.1629390927497, 6.8401297843006, 21.8520448228941, 15.3616893472612, 21.3107766402522, 24.9613969392452, 18.2809673841021, 24.1547311794734, 2.68568024987455, 3.296862573403, 10.7166459161808, 4.61263787309621, 3.25994543590123, 14.0529420991275, 12.6380775679207, 0.401743233696596, 2.17435197709279, 1.3343033465354, 0.255226406807943, 1.66194312120566, 1.00399343823993, 4.07178903620536, 20.6376378660032), 0.312794084274579, 0.0666281970608432, 4.69462026698612, 2.67102429424225e-06, classic, Inf, 0.182205217680489, 0.44338295086867, 0.0666281970608432, , NA, 0.0824475186200081, NA, NA, NA, HTS, , NA, 0.15475006120432, 24, 0.95, -0.00659434445686441, 0.632182513006023, 0.0824475186200081, 0.0824475186200081, 43.7272947845575, 25, 0.0116322939387831, REML, NULL, QP, 0.0195082647991621, 0.0243206297775738, 0.00956440915058722, 1.16034621548945, 0.139671990030794, 0.0977977972685849, 1.077193675942, NULL, , , , 1.32253234039183, 1.04766882020295, 1.66950830038396, 0.428274716668983, 0.088929547530482, 0.64122445337358, 0.16901652599532, 0.0240214688530384, 0.314011583137601, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0195082647991621, m4 = NULL), c(1.59863865246834, 2.91880411739605, 1.03496270403437, -0.240869768792693, -0.848135788138097, 2.7383312927697, 1.44731092421644, 2.88225778476268, 3.42252198523445, 2.41269150050446, 2.98425597277297, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -0.756956164290033, 2.11611701209153, 2.42433986741923, 1.66579751863686, -1.35077620077105, -0.518842147799465, -0.86582137821128, -1.13137001083399, 0.118209116937741, 2.18256491827878), FALSE, 6.3335201530061, 4.69462026698612, c(3.4194625262421, 0.572018511925952, 0.771552050951551, 5.74119183673469, 7.89342040816327, 38.0893716879198, 21.9352399354322, 36.4745844790012, 48.6532876573287, 28.4143899075398, 45.679846451436, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 19.3606301049807, 16.7735438837396, 0.404916692711883, 2.27066883094076, 1.36996341617971, 0.256503544194642, 1.71763152908857, 1.02405066856933, 4.42313424124118, 34.5460218820105), 0.339391173164126, 0.0535864992871365, 0.234363564503757, 0.444418781824495, 6.3335201530061, 2.39629990758453e-10, 6.3335201530061, Common effect model, common, NA, 0.0824475186200081, NA, 1, FALSE, FALSE
OR	26	12	1.254	1.398	1.559	<.001	.20 [.00, .50]	random	SSW	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 6.03946118687454, 1.54629701123876e-09, 0.95, 0.226343213164649, 0.44383302818103, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554855277262352, 6.03919858753366, 1.54881534132051e-09, classic, Inf, 0.22633848466622, 0.443837756679459, 0.0514169856088559, , NA, 0.0573404377704793, NA, NA, NA, HTS, , NA, 0.0514457826905406, 24, 0.95, 0.233437465425294, 0.445795219218963, 0.0573404377704793, 0.0573404377704793, 31.0928961570269, 25, 0.185961138212386, REML, NULL, QP, 2.96214754102974e-06, 0.0132053842950636, 0, 0.35508438920658, 0.00172108905668177, 0, 0.595889578031517, NULL, , , , 1.1152200887184, 1, 1.4195584385158, 0.195957820276898, 0, 0.503758079850321, 4.30943281696686e-05, 0, 0.251406981948719, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.96214754102974e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.03946118687454, 6.03919858753366, c(43.413961038961, 20.6037735849057, 21.8181818181818, 43.7485714285714, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 116.008016032064, 96, 3.99846537502398, 9.99375585388698, 11.9737226277372, 11.9737226277372, 10.9801671857073, 10.9801671857073, 81.4471243042672, 145.483503981797), 0.335088120672839, 0.0554831151827055, 0.226343213164649, 0.44383302818103, 6.03946118687454, 1.54629701123876e-09, 6.03946118687454, Common effect model, common, NA, 0.0573404377704793, NA, 1, FALSE, FALSE
OR	26	12	1.251	1.38	1.523	<.001	.03 [.00, .45]	random	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999914), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.059), 4.2-0, UM.FS
OR	26	12	1.251	1.381	1.524	<.001	.03 [.00, .45]	random (all)	glmer	c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 40.151802068837, 1, 2.34974632157943e-10, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947275, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), c(0.437616634945504, 1.5289436959849, 1.02397988189944, 0.418788266098715, 0.359042038531597, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 0.236697237555309, 0.224694534815764, 1.00047421507267, 0.645710254456962, 1.44277328939782, 1.44515941110162, 1.04930886732219, 1.44523817660532, 0.468743451662213, 0.167597482775787), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), c(0.115930725831071, 0.0446286023763406, 0.317062719150618, 0.809168952003446, 0.395858042604062, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.449324195379823, 0.0355095764845638, 0.0405843716584557, 0.110798861839944, 0.354293854097336, 0.691205424969968, 0.401680166585725, 0.495293941606134, 0.905825755999269, 0.0294321382277291 ), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.982459372902099, -0.921946563243099, -1.00855115719238, 0.116985319571512, -0.102805332404417, 0.140535924960222, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -0.642989503982276, 0.032026866395486, 0.0878289736388995, -0.235911044916875, -4.16421414660905, -2.25841454873102, -2.93658350949254, -3.81814152869228, -0.863265447331764, 0.0364835513107171 ), c(1.54568360604601, 6.06700490019927, 3.03146800593087, 0.719673274159816, 0.398867771723165, 0.717229971231204, 0.677538711711014, 0.749289992003167, 0.726812212568571, 0.748390562496355, 0.689289647560109, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 0.284846617714778, 0.912813257919242, 4.00961583164571, 2.2952266414508, 1.49135322354318, 3.40650624662557, 1.17663166772748, 1.84708802176527, 0.974175119162093, 0.693453611590945), FALSE, NULL, 26, 26, 26, 26, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 6.3183366340189, 2.64393589630211e-10, 0.95, 0.221847322447252, 0.42137719152132, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.32161225698435, 0.050901415786007, 6.3183361802043, 2.64394365881077e-10, classic, Inf, 0.221847315281678, 0.421377198687022, 0.0514150994968746, , NA, 0.0573389140751905, NA, NA, NA, HTS, , NA, 0.050901415786007, 24, 0.95, 0.21655689815878, 0.42666761580992, 0.0573389140751905, 0.0573389140751905, c(Wald = 25.6864480440851, LRT = 42.8595003971652), c(25, 25), c(0.424479285975085, 0.0145016869227605), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.0136359907597, 1, 1.3449521313059, 0.0267241326207092, 0, 0.447176692409211, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 10, 15, 17, 21, 22, 23, 24, 25, 26, 27, 28, 30, 31, 32, 33, 34, 37, 40, 43, 46, 49, 52, 56, 58), study = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004" ), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Military", "Military"), group1 = c("Music", "Musicians", "Musicians", "Music (freshmen)", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Singers", "Instrumental musicians", "Music applicants", "Music applicants", "Musicians and composers", "Musicians and composers", "Musicians, singers and related workers", "Musicians, singers and related workers", "Art Hobbies", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "Noncreatives", "HS seniors", "HS seniors", "British adults", "British adults", "British adults", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes", "Non-Art Hobbies"), h = c("Drawing hand", "AHQ", "AHQ", "4i_3pt", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "1i_2pt", "3i_3pt", "3i_3pt", "AHQ", "AHQ"), rl_sm = c("R/L", "R/L", "S/M", "R/L", "S/M", "R/L", "R/L", "R/L", "S/M", "S/M", "S/M", "R/L", "R/L", "R/L", "R/L", "R/L", "S/M", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M", "R/L", "S/M"), n_creative = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n_left_creative = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), n_right_creative = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), n_control = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), n_left_control = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n_right_control = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), PL_creative = c(14.8936170212766, 10.7142857142857, 6.66666666666667, 14.7727272727273, 73.8636363636364, 12.199036918138, 10.8761329305136, 12.5, 16.3723916532905, 15.7099697885196, 15.7534246575342, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 18.6567164179104, 30.5555555555556, 50, 60, 0, 0, 9.09090909090909, 0, 6, 45.6521739130435), PL_control = c(8.08435852372583, 0, 2.5, 16.0919540229885, 79.3103448275862, 8.38751625487646, 8.38751625487646, 8.38751625487646, 10.9882964889467, 10.9882964889467, 10.9882964889467, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 21.5277777777778, 21.5277777777778, 11.4181539052005, 34.8828491096532, 13.2040965618142, 2.1945866861741, 19.4252873563218, 10.4269293924466, 5.69476082004556, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.464423731737014, 0.402085887574389, 0.366465801257523, 1.12400690794925, 0.903213257329337, 1.15108757063211, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0.527187637804322, 1.03487564330809, 1.36783907390738, 0.848654395830455, 0, 0, 0.0683282371267135, 0, 0.433242739236992, 1.03745938361973), effect = c(1.98967391304348, Inf, 2.78571428571429, 0.903809523809524, 0.737240075614367, 1.5175658631294, 1.33291288923926, 1.56035437430786, 1.5859123896921, 1.50978770333609, 1.51474479241834, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0.836046167505179, 1.60387096774194, 7.75798319327731, 2.80010746910263, 0, 0, 0.414792899408284, 0, 1.05702127659574, 1.44046875), upper = c(4.60852887703026, Inf, 16.7260278811785, 2.0315849935859, 1.48463089912896, 2.04892526251243, 1.96704018224163, 2.11513514309315, 2.06759297841139, 2.11310579753473, 1.9926545814883, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 1.32585277817068, 2.48819701178341, 44.001011796837, 9.23886316626205, 2.1089364487342, 14.3568173617392, 2.51803875871203, 3.00482027847417, 2.58665434552118, 2.00003031683707), chi_sq = c(1.77, 5.15, 0.22, 0, 0.45, 7.06, 1.8, 7.84, 11.23, 5.38, 8.47, 0.8, 0.29, 1.15, 0.01, 0.1, 0.41, 3.98, 2.69, 1.78, 0.85, 0, 0.23, 0.41, 0, 4.4), p = c(0.183739843822423, 0.0233028301711607, 0.639881327139418, 0.974242500600563, 0.501524708120961, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.519806182964881, 0.0460363507271698, 0.101283373075042, 0.182195207371202, 0.355655057824875, 0.999999999999738, 0.628136158869253, 0.523910835874685, 0.999999999999999, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+SL)/M", "(SR+MR)/(SL+ML)", "(SR+SL)/M", "0-split", "0-split", "0-split", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "(SR+SL)/M", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "R/L", "(SR+SL)/M", "SR/SL", "(SR+SL)/M", "SR/SL", "(SR+SL)/M"), pref_success = c("preference", "mix", "mix", "pref", "pref", "success", "success", "success", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "preference", "preference", "preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 4.14844463411343, 0.415696185966884, 0.285251439998739, 0.235952895527371, 0.271389406464512, 0.245935022292584, 0.217132963345163, 0.263877639148698, 0.214595710980359, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.203744851095766, 0.37075205971613, 10.8760092173159, 2.14039871054073, 0.538003877971539, 3.66252070828443, 0.624937636841371, 0.766549870858805, 0.549349789911963, 0.245558321686005), inv_var = c(1.09447128885182, 0, 0.0581071270447214, 5.78692588561539, 12.289785670778, 17.961780199522, 13.5773251175883, 16.5332884431038, 21.2103815496508, 14.3613352417399, 21.7149045455822, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 24.0894406156262, 7.27499761251456, 0.00845397318661848, 0.218278338160219, 3.45484993264602, 0.0745486566836351, 2.56051095546973, 1.70184173708771, 3.31361520572076, 16.5840533845998), .event.e = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), .n.e = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), .event.c = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), .n.c = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), .studlab = c("peterson_1979", "preti_2007", "preti_2007", "gotestam_1990", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "byrne_1974", "byrne_1974", "cosenza_1993", "cosenza_1993", "nlsy79", "nlsy79", "nlsy97", "nlsy97", "giotakos_2004", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 8.61477765399469e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, 1.00051215324072, -0.241498276644173, -0.849041783467315, 2.72394251378171, 1.44353856821043, 2.86491186536178, 3.4024047797512, 2.40009766979648, 2.96986264213062, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.756542175917474, 2.10249912195114, 2.04775132809745, 1.59461274024973, -0.926292766405959, 0.397219742360248, -0.838624306233307, -0.681913036492282, 0.118305302652264, 2.17764954106792), FALSE, 6.3183366340189, 6.3183361802043, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.321612256984286, 0.0509014121300021, 0.221847322447252, 0.42137719152132, 6.3183366340189, 2.64393589630211e-10, 6.3183366340189, Common effect model, common, NA, 0.0573389140751905, NA, 1, FALSE, FALSE, list(b = 0.321612256984286, beta = 0.321612256984286, se = 0.0509014121300021, zval = 6.3183366340189, pval = 2.64393589630211e-10, ci.lb = 0.221847322447252, ci.ub = 0.42137719152132, vb = 0.00259095375682832, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213778207853, QMdf = c(1, NA), QMp = 2.6439358963021e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 27, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545298, 42.8595003971652, 354.247503090597, 406.931083492295, 417.247503090597), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0229999999999961), list(b = 0.32161225698435, beta = 0.32161225698435, se = 0.050901415786007, zval = 6.3183361802043, pval = 2.64394365881077e-10, ci.lb = 0.221847315281678, ci.ub = 0.421377198687022, vb = 0.00259095412901996, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0728083389374602, QE.Wld = 25.6864480440851, QEp.Wld = 0.424479285975085, QE.LRT = 42.8595003971652, QEp.LRT = 0.0145016869227605, QE.df = 25, QM = 39.9213720860787, QMdf = c(1, NA), QMp = 2.64394365881078e-10, k = 26, k.f = 26, k.yi = 26, k.eff = 52, k.all = 26, p = 1, p.eff = 27, parms = 28, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, 1.02450431651439, -0.101136644541641, -0.304841692734607, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.46115988189628, 0.411969047125437, 0.415246970922108, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -0.179071443133749, 0.472420062157364, 2.04872240264231, 1.02965779826696, -1.33643046153293, 0.574045848947276, -0.879975920882529, -0.985526753463505, 0.0554548359151648, 0.364968581450831), vi.f = c(0.191508319181027, 2.33766882549198, 1.0485347985348, 0.175383611821968, 0.128911185432925, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 0.0560255822663143, 0.0504876339760725, 1.00094865502527, 0.416941732710875, 2.08159476459981, 2.08848572349559, 1.10104909904098, 2.08871338711748, 0.219720423476205, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ti = NA), outdat = list(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), bi = c(40, 25, 28, 75, 23, 547, 295, 511, 521, 279, 492, 92, 25, 116, 102, 72, 109, 75, 2, 4, 12, 12, 10, 11, 94, 100), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), di = c(523, 78, 78, 73, 18, 1409, 1409, 1409, 1369, 1369, 1369, 96, 288, 971, 640, 640, 678, 678, 9232, 10422, 4746, 5348, 4907, 5455, 414, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ni.f = c(616, 106, 110, 175, 175, 2161, 1869, 2122, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 998, 972, 10426, 16015, 5480, 5480, 6101, 6101, 539, 879), ids = 1:26, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:26, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-150.123751545489, 42.8595003975462, 356.247503090978, 410.882327211258, 426.856198743151), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 2, 13, 65, 76, 36, 73, 102, 52, 92, 8, 6, 13, 7, 3, 25, 33, 2, 6, 0, 0, 1, 0, 6, 84), ci = c(46, 0, 2, 14, 69, 129, 129, 129, 169, 169, 169, 4, 47, 157, 38, 38, 186, 186, 1190, 5583, 722, 120, 1183, 635, 25, 256), n1i = c(47, 28, 30, 88, 88, 623, 331, 584, 623, 331, 584, 100, 31, 129, 109, 75, 134, 108, 4, 10, 12, 12, 11, 11, 100, 184), n2i = c(569, 78, 80, 87, 87, 1538, 1538, 1538, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 864, 864, 10422, 16005, 5468, 5468, 6090, 6090, 439, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 1.095), 4.2-0, UM.FS

Final table

Final table
N	N_stu	study	rl_sm	group1	group2	pL_creative	pL_control	lower	effect	upper	p	I2	comparison	model_type	label	es_type	se
Architecture
17	9							0.914	1.044	1.193	.53	.20 [.00, .55]		random (all)	glmer	OR
		shettel-neuber_1983	S/M	Architecture	Law, Psychology	0/23 (0%)	2/55 (3.64%)	0	0	4.737	.89		(SR+SL)/M			OR	1.208
		nlsy79	R/L	Architects, except naval	Non-art, architecture, music	0/9 (0%)	722/5468 (13.2%)	0	0	2.812	.50		R/L			OR	0.717
		nlsy79	S/M	Architects, except naval	Non-art, architecture, music	0/9 (0%)	120/5468 (2.19%)	0	0	19.165	1.00		(SR+SL)/M			OR	4.889
		nlsy97	R/L	Architects, except naval	Non-art, architecture, music	0/4 (0%)	1183/6090 (19.43%)	0	0	3.991	.73		SR/SL			OR	1.018
		nlsy97	S/M	Architects, except naval	Non-art, architecture, music	0/4 (0%)	635/6090 (10.43%)	0	0	8.271	1.00		(SR+SL)/M			OR	2.11
		wood_1991	R/L	Architecture students (W)	General students (W)	1/27 (3.7%)	22/149 (14.77%)	0.037	0.222	1.37	.21		SR/SL			OR	0.34
		shettel-neuber_1983	R/L	Architecture	Law, Psychology	1/23 (4.35%)	5/53 (9.43%)	0.064	0.436	3.096	.77		SR/SL			OR	0.773
		gotestam_1990	R/L	Architecture (freshmen)	HS seniors	7/60 (11.67%)	14/87 (16.09%)	0.266	0.689	1.788	.61		(SR+MR)/(SL+ML)			OR	0.388
		gotestam_1990	S/M	Architecture (freshmen)	HS seniors	45/60 (75%)	69/87 (79.31%)	0.36	0.783	1.699	.68		(SR+SL)/M			OR	0.341
		wood_1991	R/L	Architecture students (M)	General students (M)	9/78 (11.54%)	28/221 (12.67%)	0.41	0.899	1.975	.95		SR/SL			OR	0.399
		cosenza_1993	S/M	Architecture applicants	Non-art/music/ architecture applicants	179/526 (34.03%)	5583/16005 (34.88%)	0.802	0.963	1.157	.72		(SR+SL)/M			OR	0.091
		cosenza_1993	R/L	Architecture applicants	Non-art/music/ architecture applicants	42/347 (12.1%)	1190/10422 (11.42%)	0.77	1.068	1.482	.76		SR/SL			OR	0.182
		schacter_1996	S/M	Architects	Non-architects	7/148 (4.73%)	41/1048 (3.91%)	0.547	1.219	2.719	.80		(SR+SL)/M			OR	0.554
		fry_1990	R/L	Architecture	Non-architecture	12/69 (17.39%)	41/297 (13.8%)	0.656	1.315	2.639	.57		R/L			OR	0.506
		peterson_1979	R/L	Design, Arch., Art	Non-art, music	18/147 (12.24%)	46/569 (8.08%)	0.895	1.586	2.814	.16		R/L			OR	0.489
		schacter_1996	R/L	Architects	Non-architects	26/141 (18.44%)	92/1007 (9.14%)	1.4	2.249	3.613	.001		SR/SL			OR	0.565
		wood_1991	S/M	Architecture students (W)	General students (W)	2/27 (7.41%)	2/149 (1.34%)	0.985	5.88	35.164	.21		(SR+SL)/M			OR	8.719
Art
17	9							1.379	1.609	1.878	<.001	.59 [.30, .76]		random (all)	glmer	OR
		nlsy79	R/L	Artistic occupations	Non-art, architecture, music	2/43 (4.65%)	722/5468 (13.2%)	0.085	0.321	1.205	.15		R/L			OR	0.286
		shettel-neuber_1983	R/L	Art	Law, Psychology	1/30 (3.33%)	5/53 (9.43%)	0.049	0.331	2.314	.56		SR/SL			OR	0.578
		shettel-neuber_1983	S/M	Art	Law, Psychology	1/31 (3.23%)	2/55 (3.64%)	0.111	0.883	7.173	1.00		(SR+SL)/M			OR	1.802
		giotakos_2004	R/L	Art Hobbies	Non-Art Hobbes	6/100 (6%)	25/439 (5.69%)	0.433	1.057	2.587	1.00		SR/SL			OR	0.549
		nlsy79	S/M	Artistic occupations	Non-art, architecture, music	1/43 (2.33%)	120/5468 (2.19%)	0.183	1.061	6.164	1.00		(SR+SL)/M			OR	1.526
		nlsy97	S/M	Artistic occupations	Non-art, architecture, music	9/78 (11.54%)	636/6091 (10.44%)	0.563	1.119	2.224	.90		(SR+SL)/M			OR	0.424
		cosenza_1993	R/L	Fine Arts applicants	Non-art/music/ architecture applicants	4/31 (12.9%)	1190/10422 (11.42%)	0.419	1.149	3.155	1.00		SR/SL			OR	0.698
		cosenza_1993	S/M	Fine Arts applicants	Non-art/music/ architecture applicants	20/51 (39.22%)	5583/16005 (34.88%)	0.691	1.204	2.1	.62		(SR+SL)/M			OR	0.36
		coren_1982	R/L	Science/Visual Art	Lang/Lit	28/225 (12.44%)	27/262 (10.31%)	0.709	1.237	2.159	.55		0 split			OR	0.37
		nlsy97	R/L	Artistic occupations	Non-art, architecture, music	19/78 (24.36%)	1184/6091 (19.44%)	0.797	1.335	2.236	.34		SR/SL			OR	0.367
		giotakos_2004	S/M	Art Hobbies	Non-Art Hobbies	84/184 (45.65%)	256/695 (36.83%)	1.037	1.44	2	.04		(SR+SL)/M			OR	0.246
		peterson_1979	R/L	Design, Arch., Art	Non-art, music	18/147 (12.24%)	46/569 (8.08%)	0.895	1.586	2.814	.16		R/L			OR	0.489
		mebert_1980	S/M	Art	Non-Art	28/103 (27.18%)	15/101 (14.85%)	1.069	2.14	4.28	.05		(SR+SL)/M			OR	0.819
		mebert_1980	R/L	Art	Non-Art	21/75 (28%)	7/86 (8.14%)	1.772	4.389	10.816	.002		SR/SL			OR	2.307
		coren_1982	S/M	Science/Visual Art	Lang/Lit	69/225 (30.67%)	21/262 (8.02%)	3.002	5.076	8.582	<.001		SR/(M+SL)			OR	1.423
		preti_2007	S/M	Writers, Painters	Noncreatives	8/50 (16%)	2/80 (2.5%)	1.68	7.429	32.361	.01		(SR+SL)/M			OR	7.827
		preti_2007	R/L	Writers, Painters	Noncreatives	2/42 (4.76%)	0/78 (0%)	0.974	Inf	Inf	.23		SR/SL			OR	Inf
Music
26	12							1.251	1.381	1.524	<.001	.03 [.00, .45]		random (all)	glmer	OR
		nlsy79	R/L	Musicians and composers	Non-art, architecture, music	0/12 (0%)	722/5468 (13.2%)	0	0	2.109	.36		R/L			OR	0.538
		nlsy79	S/M	Musicians and composers	Non-art, architecture, music	0/12 (0%)	120/5468 (2.19%)	0	0	14.357	1.00		(SR+SL)/M			OR	3.663
		nlsy97	S/M	Musicians, singers and related workers	Non-art, architecture, music	0/11 (0%)	635/6090 (10.43%)	0	0	3.005	.52		(SR+SL)/M			OR	0.767
		nlsy97	R/L	Musicians, singers and related workers	Non-art, architecture, music	1/11 (9.09%)	1183/6090 (19.43%)	0.068	0.415	2.518	.63		SR/SL			OR	0.625
		oldfield_1969	R/L	Music students and faculty	Psychology undergrads	13/129 (10.08%)	157/1128 (13.92%)	0.384	0.693	1.252	.28		0-split			OR	0.221
		byrne_1974	R/L	Instrumental musicians	General students	3/75 (4%)	38/678 (5.6%)	0.224	0.702	2.203	.75		SR/SL			OR	0.505
		gotestam_1990	S/M	Music (freshmen)	HS seniors	65/88 (73.86%)	69/87 (79.31%)	0.366	0.737	1.485	.50		(SR+SL)/M			OR	0.285
		byrne_1974	S/M	Singers	General students	25/134 (18.66%)	186/864 (21.53%)	0.527	0.836	1.326	.52		(SR+SL)/M			OR	0.204
		gotestam_1990	R/L	Music (freshmen)	HS seniors	13/88 (14.77%)	14/87 (16.09%)	0.402	0.904	2.032	.97		(SR+MR)/(SL+ML)			OR	0.416
		giotakos_2004	R/L	Art Hobbies	Non-Art Hobbes	6/100 (6%)	25/439 (5.69%)	0.433	1.057	2.587	1.00		SR/SL			OR	0.549
		byrne_1974	R/L	Singers	General students	7/109 (6.42%)	38/678 (5.6%)	0.513	1.156	2.611	.91		SR/SL			OR	0.535
		aggleton_1994	R/L	Composers	British adults	36/331 (10.88%)	129/1538 (8.39%)	0.903	1.333	1.967	.18		0-split			OR	0.271
		giotakos_2004	S/M	Art Hobbies	Non-Art Hobbies	84/184 (45.65%)	256/695 (36.83%)	1.037	1.44	2	.04		(SR+SL)/M			OR	0.246
		fry_1990	R/L	Music theory/composition	Non-music	6/31 (19.35%)	47/335 (14.03%)	0.588	1.471	3.694	.59		R/L			OR	0.792
		aggleton_1994	S/M	Composers	British adults	52/331 (15.71%)	169/1538 (10.99%)	1.079	1.51	2.113	.02		(SR+SL)/(ML+MR)			OR	0.264
		aggleton_1994	S/M	Choir Members	British adults	92/584 (15.75%)	169/1538 (10.99%)	1.151	1.515	1.993	.004		(SR+SL)/(ML+MR)			OR	0.215
		aggleton_1994	R/L	Instrumental musicians	British adults	76/623 (12.2%)	129/1538 (8.39%)	1.124	1.518	2.049	.008		0-split			OR	0.236
		aggleton_1994	R/L	Choir Members	British adults	73/584 (12.5%)	129/1538 (8.39%)	1.151	1.56	2.115	.005		0-split			OR	0.246
		aggleton_1994	S/M	Instrumental musicians	British adults	102/623 (16.37%)	169/1538 (10.99%)	1.216	1.586	2.068	<.001		(SR+SL)/(ML+MR)			OR	0.217
		byrne_1974	S/M	Instrumental musicians	General students	33/108 (30.56%)	186/864 (21.53%)	1.035	1.604	2.488	.05		(SR+SL)/M			OR	0.371
		peterson_1979	R/L	Music	Non-art, music	7/47 (14.89%)	46/569 (8.08%)	0.862	1.99	4.609	.18		R/L			OR	0.956
		quinan_1922	R/L	Instrumental musicians	Machinists	8/100 (8%)	4/100 (4%)	0.641	2.087	6.756	.37		R/L			OR	1.56
		preti_2007	S/M	Musicians	Noncreatives	2/30 (6.67%)	2/80 (2.5%)	0.464	2.786	16.726	.64		(SR+SL)/M			OR	4.148
		cosenza_1993	S/M	Music applicants	Non-art/music/ architecture applicants	6/10 (60%)	5583/16005 (34.88%)	0.849	2.8	9.239	.18		(SR+SL)/M			OR	2.14
		cosenza_1993	R/L	Music applicants	Non-art/music/ architecture applicants	2/4 (50%)	1190/10422 (11.42%)	1.368	7.758	44.001	.10		SR/SL			OR	10.876
		preti_2007	R/L	Musicians	Noncreatives	3/28 (10.71%)	0/78 (0%)	2.295	Inf	Inf	.02		SR/SL			OR	Inf

Blank (collapse)

R/L

Left/right comparisons only — an odds ratio greater than one is a lefty advantage.

From raw proportions, using metabin

All studies

From raw proportions, using metabin
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	10	9	0.95	1.175	1.453	.14	.31 [.00, .67]	random	GLMM	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.240000000000009), 4.2-0, UM.FS
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	Inverse	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 2.00710339976287, 0.0447386543136591, 0.95, 0.00512777382132965, 0.431533233590776, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 2.00710339976287, 0.94532892002845, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 0.00512777382132965, 0.431533233590776, 2.00710339976287, 0.0447386543136591, 2.00710339976287, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	MH	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 10, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, 1.48226068135845, 0.138270945925028, 0.95, -0.0515708594286942, 0.371608241317837, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48226068135845, 0.94532892002845, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, -0.0515708594286942, 0.371608241317837, 1.48226068135845, 0.138270945925028, 1.48226068135845, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.704	1.055	1.58	.80	.52 [.00, .76]	random	Peto	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.690261338333529, 1.00795306164762, -0.358939974457216, -0.103975776405053, -0.96814727649067, 0.288825505247073, 0.0676634264671485, -1.15352537697584, -1.24149907767122, 0.510435812545122), c(0.919851510749532, 0.295964545973394, 0.4779292284239, 0.39928626800966, 0.618795351373702, 0.379240441958542, 0.171431799285525, 0.986041272695215, 1.26445115535852, 0.32406897670339), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), c(0.453010712212803, 0.000660055934616421, 0.452633611523925, 0.794552090065137, 0.117684285849375, 0.446305096005573, 0.693067336878847, 0.242059299632813, 0.326174643421658, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-2.49313717052737, 0.427873210839015, -1.29566404932708, -0.886562481225394, -2.18096387898393, -0.454472102472721, -0.26833672593738, -3.0861307587285, -3.71977780238397, -0.124727710300273), c(1.11261449386031, 1.58803291245622, 0.577784100412645, 0.678610928415287, 0.244669326002593, 1.03212311296687, 0.403663578871677, 0.779080004776819, 1.23677964704154, 1.14559933539052), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, 1.4884732078, 0.136626142703563, 0.95, -0.0533805713994409, 0.390420251770235, c(0.960198499794839, 3.53457387542192, 2.35993284854623, 2.81885438124734, 1.729409020091, 2.94856665294313, 4.45011319425951, 0.856456286477261, 0.557363504168402, 3.32950190940788), 0.0534179929825893, 0.20608715679561, 0.259200979882349, 0.795480175097968, classic, Inf, -0.350505412013065, 0.457341397978243, 0.20608715679561, , NA, 0.20687983499037, NA, NA, NA, HTS, , NA, 0.48764376290358, 8, 0.95, -1.07109054077959, 1.17792652674476, 0.20687983499037, 0.20687983499037, 18.5750500735711, 9, 0.0290586285493781, REML, NULL, QP, 0.195324523302665, 0.183532166741211, 0, 1.40213305779073, 0.441955340846408, 0, 1.18411699497589, NULL, , , , 1.43662606568968, 1.00221052340108, 2.05934222843223, 0.515479098879774, 0.00440643064809634, 0.764200462066889, 0.459891007509119, 0.0309646561078429, 0.888817358910395, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.195324523302665, m4 = NULL), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), FALSE, 1.4884732078, 0.259200979882349, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, -0.0533805713994409, 0.390420251770235, 1.4884732078, 0.136626142703563, 1.4884732078, Common effect model, common, NA, 0.20687983499037, NA, 1, FALSE, FALSE
OR	10	9	0.799	1.155	1.669	.44	.37 [.00, .70]	random	SSW	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, 1.28169151418932, 0.199950882897494, 0.95, -0.0761882335636568, 0.364125063401724, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.188002448932881, 0.765779465832555, 0.443807534315363, classic, Inf, -0.224509613994744, 0.512446443832811, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.28169151418932, 0.765779465832555, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, -0.0761882335636568, 0.364125063401724, 1.28169151418932, 0.199950882897494, 1.28169151418932, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
Art
OR	9	9	1.036	1.335	1.721	.03	.36 [.00, .71]	random	GLMM	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.468000000000018), 4.2-0, UM.FS
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	Inverse	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 2.36328689542623, 0.0181136409332486, 0.95, 0.0551492824997776, 0.591149616501597, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.36328689542623, 2.36320065200989, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 0.0551492824997776, 0.591149616501597, 2.36328689542623, 0.0181136409332486, 2.36328689542623, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	MH	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 2.2621762204149, 0.023686517892065, 0.95, 0.0396402762420969, 0.553805518736806, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.2621762204149, 2.36320065200989, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 0.0396402762420969, 0.553805518736806, 2.2621762204149, 0.023686517892065, 2.2621762204149, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	0.865	1.33	2.043	.19	.55 [.05, .79]	random	Peto	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.37380660954712, -0.898720357210923, 2.88135593220339, 0.146763960036387, -0.749367968408782, 0.313395219413491, 0.510435812545122, 0.0562064185176206, 0.213083622484386), c(0.415528842183368, 0.876931092336367, 1.48876715444574, 0.565457624206178, 0.453165389135724, 0.287580331760914, 0.32406897670339, 0.475482940518229, 0.286867912404376), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), c(0.000945826213271411, 0.305435300635845, 0.0529415602967437, 0.795211681566248, 0.0982026747675452, 0.275816308736864, 0.115237090566695, 0.905901966336454, 0.457606707594208), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, -2.61747371511357, -0.0365740718764318, -0.961512618191306, -1.63755581015488, -0.250251873499981, -0.124727710300273, -0.87572302016131, -0.349167154148383), c(2.18822817476415, 0.820033000691724, 5.79928593628321, 1.25504053826408, 0.138819873337315, 0.877042312326963, 1.14559933539052, 0.988135857196551, 0.775334399117154), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 2.23540959240253, 0.0253904709368229, 0.95, 0.0375779984132761, 0.572358887262285, c(2.63328804460967, 1.02448804204668, 0.412623508509967, 1.89814020605396, 2.42454795983714, 3.45075570522832, 3.20400013509703, 2.30854553951527, 3.45563580607993), 0.284955293439964, 0.219201151428492, 1.29997169988828, 0.193610668850246, classic, Inf, -0.14467106872959, 0.714581655609518, 0.219201151428492, , NA, 0.248402616236765, NA, NA, NA, HTS, , NA, 0.505112158473251, 7, 0.95, -0.909445166260264, 1.47935575314019, 0.248402616236765, 0.248402616236765, 17.7657933508844, 8, 0.0230525678308733, REML, NULL, QP, 0.20708914784993, 0.203168694400191, 0.00314061140378238, 3.42467830718788, 0.455070486683031, 0.0560411581231365, 1.85058863802518, NULL, , , , 1.49020943791823, 1.02473642222004, 2.16711743694, 0.549696439556878, 0.0476958985820897, 0.787070856624646, 0.478882723477907, 0.0968404089229942, 0.860925038032819, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.20708914784993, m4 = NULL), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), FALSE, 2.23540959240253, 1.29997169988828, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 0.0375779984132761, 0.572358887262285, 2.23540959240253, 0.0253904709368229, 2.23540959240253, Common effect model, common, NA, 0.248402616236765, NA, 1, FALSE, FALSE
OR	9	9	0.974	1.339	1.839	.07	.43 [.00, .74]	random	SSW	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, 1.79950836241973, 0.0719383023115588, 0.95, -0.0260037780075166, 0.609268052087494, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162065287495661, 1.79947317248795, 0.0719438639077346, classic, Inf, -0.0260099895956367, 0.609274263675614, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 1.79950836241973, 1.79947317248795, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, -0.0260037780075166, 0.609268052087494, 1.79950836241973, 0.0719383023115588, 1.79950836241973, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
Music
OR	15	12	1.142	1.334	1.558	<.001	.02 [.00, .55]	random	GLMM	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000387), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.407000000000039), 4.2-0, UM.FS
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	Inverse	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 3.88401281096207, 0.000102746490259109, 0.95, 0.155324355220281, 0.471771773781667, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.88401281096207, 3.82062176216205, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 0.155324355220281, 0.471771773781667, 3.88401281096207, 0.000102746490259109, 3.88401281096207, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	MH	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 14, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 3.64677076815372, 0.000265556628429634, 0.95, 0.134154570578494, 0.44591301173438, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.64677076815372, 3.82062176216205, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 0.134154570578494, 0.44591301173438, 3.64677076815372, 0.000265556628429634, 3.64677076815372, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.048	1.304	1.623	.02	.50 [.10, .73]	random	Peto	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, -0.100526663026663, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, 3.80987443815582, -1.15406139984312, -0.660637623336967, 0.0562064185176206), c(0.540780565579624, 1.32219331813667, 0.417348609294271, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 1.57151003840543, 0.854369065122966, 0.763018377649432, 0.475482940518229), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), c(0.10990091605911, 0.00351376944795559, 0.809656053389246, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.0153362452313665, 0.176767133978651, 0.386588123690052, 0.905901966336454), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -0.918514906241311, 0.126119628474816, -0.109459222670617, 0.15271233326912, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, 0.729771361538017, -2.82859399698928, -2.15612616307204, -0.87572302016131), c(1.92442314671454, 6.45067458511826, 0.717461580187986, 0.761269452833273, 0.727504996658277, 0.801769440950646, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 6.88997751477362, 0.520471197303052, 0.834850916398102, 0.988135857196551), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 3.64237828972792, 0.00027013070886894, 0.95, 0.140885481768204, 0.469140501187361, c(3.02812775867362, 0.559913985849404, 4.71757530577234, 15.6134167757432, 11.9929702856244, 15.3351211986603, 2.55996515777787, 3.10941550109688, 8.96073806023234, 4.25385545912247, 3.07655604025104, 0.398813571428646, 1.30252439967449, 1.61292798744651, 3.78963775592615), 0.265293388296449, 0.111586324076742, 2.37747224394629, 0.0174317548328194, classic, Inf, 0.0465882119388207, 0.483998564654077, 0.111586324076742, , NA, 0.146574865323034, NA, NA, NA, HTS, , NA, 0.224153841952073, 13, 0.95, -0.218961546082525, 0.749548322675422, 0.146574865323034, 0.146574865323034, 28.2042497518316, 14, 0.013365314539765, REML, NULL, QP, 0.0377934371409155, 0.0558193149766794, 0.0153224119366302, 3.4330894889523, 0.194405342367219, 0.123783730500539, 1.85285981362657, NULL, , , , 1.41936227510385, 1.05509731292569, 1.90938716581667, 0.503620903828834, 0.101713307390774, 0.725708719562553, 0.20234999106332, 0.0267758214048096, 0.37792416072183, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0377934371409155, m4 = NULL), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), FALSE, 3.64237828972792, 2.37747224394629, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 0.140885481768204, 0.469140501187361, 3.64237828972792, 0.00027013070886894, 3.64237828972792, Common effect model, common, NA, 0.146574865323034, NA, 1, FALSE, FALSE
OR	15	12	1.147	1.357	1.606	<.001	.26 [.00, .60]	random	SSW	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 3.58778867043299, 0.000333494416493596, 0.95, 0.138507650203251, 0.472044803600983, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0858781448081737, 3.55476038267959, 0.000378323701918848, classic, Inf, 0.136958156018981, 0.473594297785252, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.58778867043299, 3.55476038267959, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 0.138507650203251, 0.472044803600983, 3.58778867043299, 0.000333494416493596, 3.58778867043299, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE

Excluding Cosenza 1993

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	9	8	0.954	1.265	1.676	.10	.30 [.00, .67]	random	GLMM	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, 1.63466651027623, 0.102118976648984, 0.95, -0.0467099344460416, 0.516158187672964, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613223, 0.14359149447742, 1.63466594917385, 0.10211909433794, classic, Inf, -0.0467100310488014, 0.516158284275248, 0.197875579865113, , NA, 0.203572685665658, NA, NA, NA, HTS, , NA, 0.14359149447742, 7, 0.95, -0.104815803550535, 0.574264056776982, 0.203572685665658, 0.203572685665658, c(Wald = 11.3898392511646, LRT = 18.9345999102618), c(8, 8), c(0.180573381004509, 0.0152133477543868), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.19320153636994, 1, 1.75311033794514, 0.297619586757382, 0, 0.674627009820718, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0960086613447547, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.63466651027623, 1.63466594917385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, -0.0467099344460416, 0.516158187672964, 1.63466651027623, 0.102118976648984, 1.63466651027623, Common effect model, common, NA, 0.203572685665658, NA, 1, FALSE, FALSE, list(b = 0.234724126613461, beta = 0.234724126613461, se = 0.143591445189513, zval = 1.63466651027623, pval = 0.102118976648984, ci.lb = -0.0467099344460416, ci.ub = 0.516158187672964, vb = 0.0206185031316129, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213459981865, QMdf = c(1, NA), QMp = 0.102118976648984, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628195841, 18.9345999102618, 115.868325639168, 124.77204321813, 147.29689706774), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0230000000000246), list(b = 0.234724126613223, beta = 0.234724126613223, se = 0.14359149447742, zval = 1.63466594917385, pval = 0.10211909433794, ci.lb = -0.0467100310488014, ci.ub = 0.516158284275248, vb = 0.0206185172862589, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213276538845, QMdf = c(1, NA), QMp = 0.10211909433794, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628198105, 18.9345999107145, 117.868325639621, 127.662414976479, 161.868325639621), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.214999999999975), 4.2-0, UM.FS
OR	9	8	0.748	1.152	1.774	.52	.38 [.00, .71]	random	Inverse	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.329509991256909, 0.143086301077847, 2.30287587822707, 0.0212858277111525, 0.95, 0.0490659944632743, 0.609953988050543, c(0.705757817827661, 4.76761638760495, 2.51584329682069, 3.15329824401809, 0.804881531344106, 3.57395007080418, 0.442970496631443, 0.421247787180501, 4.20897675841021), 0.141574727045392, 0.220355516221337, 0.642483244681685, 0.520559464965204, classic, Inf, -0.29031414854316, 0.573463602633944, 0.220355516221337, , NA, 0.210895111087409, NA, NA, NA, HTS, , NA, 0.446301826754807, 7, 0.95, -0.913761396029185, 1.19691085011997, 0.210895111087409, 0.210895111087409, 12.8854753288193, 8, 0.115851263596355, REML, NULL, QP, 0.150628767035506, 0.18896539094859, 0, 1.49760037325446, 0.388109220497923, 0, 1.2237648357648, NULL, , , , 1.26912742311496, 1, 1.87096355216616, 0.379145914616946, 0, 0.714326901289134, 0.344681169773648, 0, 0.828833389962596, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.150628767035506, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 2.30287587822707, 0.642483244681685, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.329509991256909, 0.143086301077847, 0.0490659944632743, 0.609953988050543, 2.30287587822707, 0.0212858277111525, 2.30287587822707, Common effect model, common, NA, 0.210895111087409, NA, 1, FALSE, FALSE
OR	9	8	0.748	1.152	1.774	.52	.38 [.00, .71]	random	MH	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), 9, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.229404232066934, 0.142027900544679, 1.61520540110194, 0.106266221307819, 0.95, -0.0489653378004734, 0.507773801934342, c(0.705757817827661, 4.76761638760495, 2.51584329682069, 3.15329824401809, 0.804881531344106, 3.57395007080418, 0.442970496631443, 0.421247787180501, 4.20897675841021), 0.141574727045392, 0.220355516221337, 0.642483244681685, 0.520559464965204, classic, Inf, -0.29031414854316, 0.573463602633944, 0.220355516221337, , NA, 0.210895111087409, NA, NA, NA, HTS, , NA, 0.446301826754807, 7, 0.95, -0.913761396029185, 1.19691085011997, 0.210895111087409, 0.210895111087409, 12.8854753288193, 8, 0.115851263596355, REML, NULL, QP, 0.150628767035506, 0.18896539094859, 0, 1.49760037325446, 0.388109220497923, 0, 1.2237648357648, NULL, , , , 1.26912742311496, 1, 1.87096355216616, 0.379145914616946, 0, 0.714326901289134, 0.344681169773648, 0, 0.828833389962596, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.150628767035506, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.61520540110194, 0.642483244681685, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.229404232066934, 0.142027900544679, -0.0489653378004734, 0.507773801934342, 1.61520540110194, 0.106266221307819, 1.61520540110194, Common effect model, common, NA, 0.210895111087409, NA, 1, FALSE, FALSE
OR	9	8	0.607	1.004	1.66	.99	.55 [.06, .79]	random	Peto	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.690261338333529, 1.00795306164762, -0.358939974457216, -0.103975776405053, -0.96814727649067, 0.288825505247073, -1.15352537697584, -1.24149907767122, 0.510435812545122), c(0.919851510749532, 0.295964545973394, 0.4779292284239, 0.39928626800966, 0.618795351373702, 0.379240441958542, 0.986041272695215, 1.26445115535852, 0.32406897670339), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, -1.16985506481167, -0.981848189556368, 1.57508385325112), c(0.453010712212803, 0.000660055934616421, 0.452633611523925, 0.794552090065137, 0.117684285849375, 0.446305096005573, 0.242059299632813, 0.326174643421658, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-2.49313717052737, 0.427873210839015, -1.29566404932708, -0.886562481225394, -2.18096387898393, -0.454472102472721, -3.0861307587285, -3.71977780238397, -0.124727710300273), c(1.11261449386031, 1.58803291245622, 0.577784100412645, 0.678610928415287, 0.244669326002593, 1.03212311296687, 0.779080004776819, 1.23677964704154, 1.14559933539052), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.246534869948132, 0.150774800309797, 1.63511985717491, 0.102023924239927, 0.95, -0.0489783084352898, 0.542048048331553, c(0.876613019731404, 2.61627765535582, 1.91188590567729, 2.2023669532375, 1.47593828744402, 2.28075798121761, 0.789325286168537, 0.528132526261817, 2.50220119860837), 0.00379317427114306, 0.25663392730381, 0.0147804863955209, 0.988207307482815, classic, Inf, -0.499200080455394, 0.50678642899768, 0.25663392730381, , NA, 0.247415023089913, NA, NA, NA, HTS, , NA, 0.600406852916655, 7, 0.95, -1.41594343095808, 1.42352977950037, 0.247415023089913, 0.247415023089913, 17.9612007715798, 8, 0.0215192582287565, REML, NULL, QP, 0.294627416385904, 0.2782551500381, 0.00406377289159129, 1.80612497632109, 0.542795925174374, 0.0637477285210327, 1.3439214918741, NULL, , , , 1.49838249337326, 1.03109666021091, 2.17743901525996, 0.554595480461503, 0.0594080886481978, 0.7890847416068, 0.49705278079773, 0.0932550710328722, 0.900850490562587, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.294627416385904, m4 = NULL), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, -1.16985506481167, -0.981848189556368, 1.57508385325112), FALSE, 1.63511985717491, 0.0147804863955209, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.246534869948132, 0.150774800309797, -0.0489783084352898, 0.542048048331553, 1.63511985717491, 0.102023924239927, 1.63511985717491, Common effect model, common, NA, 0.247415023089913, NA, 1, FALSE, FALSE
OR	9	8	0.784	1.225	1.915	.37	.38 [.00, .71]	random	SSW	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.203207790146141, 0.151295612470405, 1.34311753545325, 0.179233918360312, 0.95, -0.093326161314782, 0.499741741607065, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.203207790146141, 0.227805793017127, 0.892022048494892, 0.37238111454421, classic, Inf, -0.243283359637014, 0.649698939929297, 0.220355516221337, , NA, 0.210895111087409, NA, NA, NA, HTS, , NA, 0.446301826754807, 7, 0.95, -0.913761396029185, 1.19691085011997, 0.210895111087409, 0.210895111087409, 12.8854753288193, 8, 0.115851263596355, REML, NULL, QP, 0.150628767035506, 0.18896539094859, 0, 1.49760037325446, 0.388109220497923, 0, 1.2237648357648, NULL, , , , 1.26912742311496, 1, 1.87096355216616, 0.379145914616946, 0, 0.714326901289134, 0.344681169773648, 0, 0.828833389962596, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.150628767035506, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.34311753545325, 0.892022048494892, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.203207790146141, 0.151295612470405, -0.093326161314782, 0.499741741607065, 1.34311753545325, 0.179233918360312, 1.34311753545325, Common effect model, common, NA, 0.210895111087409, NA, 1, FALSE, FALSE
Art
OR	8	8	1.038	1.348	1.752	.03	.44 [.00, .75]	random	GLMM	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 2.23601771732356, 0.0253506106201736, 0.95, 0.036909551002931, 0.561020490723652, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863291, 0.133704231109007, 2.23601765167438, 0.0253506149203079, classic, Inf, 0.0369095433090169, 0.561020498417565, 0.141408063317076, , NA, 0.199766622478753, NA, NA, NA, HTS, , NA, 0.133704231109007, 6, 0.95, -0.0281974467855646, 0.626127488512146, 0.199766622478753, 0.199766622478753, c(Wald = 12.4208321157769, LRT = 19.4242668574118), c(7, 7), c(0.0875415589706421, 0.00695718956281426), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.33206778655147, 1, 2.00247657038577, 0.436430672699567, 0, 0.750617994479567, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 4.69439976702832e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23601771732356, 2.23601765167438, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 0.036909551002931, 0.561020490723652, 2.23601771732356, 0.0253506106201736, 2.23601771732356, Common effect model, common, NA, 0.199766622478753, NA, 1, FALSE, FALSE, list(b = 0.298965020863292, beta = 0.298965020863292, se = 0.133704227183469, zval = 2.23601771732356, pval = 0.0253506106201736, ci.lb = 0.036909551002931, ci.ub = 0.561020490723652, vb = 0.0178768203667287, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977523218488, QMdf = c(1, NA), QMp = 0.0253506106201736, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856284012, 19.4242668574118, 106.546771256802, 113.50006975696, 136.546771256802), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.298965020863291, beta = 0.298965020863291, se = 0.133704231109007, zval = 2.23601765167438, pval = 0.0253506149203079, ci.lb = 0.0369095433090169, ci.ub = 0.561020498417565, vb = 0.0178768214164508, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977493859941, QMdf = c(1, NA), QMp = 0.025350614920308, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856285378, 19.4242668576848, 108.546771257076, 116.272658479473, 152.546771257076), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.192999999999984), 4.2-0, UM.FS
OR	8	8	0.917	1.38	2.077	.12	.50 [.00, .78]	random	Inverse	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.335922714451585, 0.141404568513512, 2.37561429579615, 0.0175197655305142, 0.95, 0.0587748529156754, 0.613070575987495, c(2.87716145938105, 0.723993464059308, 0.390115707253933, 1.53398269612545, 5.08799785552335, 4.69769142243164, 2.89324836288242, 4.80781641441746), 0.322286678464518, 0.208460006832123, 1.54603601603093, 0.122095869874814, classic, Inf, -0.0862874271434179, 0.730860784072453, 0.208460006832123, , NA, 0.25454058594184, NA, NA, NA, HTS, , NA, 0.411542733141354, 6, 0.95, -0.684722112511652, 1.32929546944069, 0.25454058594184, 0.25454058594184, 13.9701732586351, 7, 0.0517144010186448, REML, NULL, QP, 0.125911846753007, 0.16706379983961, 0, 4.29410873817914, 0.354840593440219, 0, 2.07222313908979, NULL, , , , 1.4127062812021, 1, 2.11386241427388, 0.498932484915801, 0, 0.776206964839883, 0.362185543371354, 0.00568688699747616, 0.718684199745232, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.125911846753007, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.37561429579615, 1.54603601603093, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.335922714451585, 0.141404568513512, 0.0587748529156754, 0.613070575987495, 2.37561429579615, 0.0175197655305142, 2.37561429579615, Common effect model, common, NA, 0.25454058594184, NA, 1, FALSE, FALSE
OR	8	8	0.917	1.38	2.077	.12	.50 [.00, .78]	random	MH	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), 7, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 1.74698795180723, 0, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.306772213661016, 0.135426398300959, 2.26523201908741, 0.0234984452372663, 0.95, 0.0413413504351605, 0.572203076886871, c(2.87716145938105, 0.723993464059308, 0.390115707253933, 1.53398269612545, 5.08799785552335, 4.69769142243164, 2.89324836288242, 4.80781641441746), 0.322286678464518, 0.208460006832123, 1.54603601603093, 0.122095869874814, classic, Inf, -0.0862874271434179, 0.730860784072453, 0.208460006832123, , NA, 0.25454058594184, NA, NA, NA, HTS, , NA, 0.411542733141354, 6, 0.95, -0.684722112511652, 1.32929546944069, 0.25454058594184, 0.25454058594184, 13.9701732586351, 7, 0.0517144010186448, REML, NULL, QP, 0.125911846753007, 0.16706379983961, 0, 4.29410873817914, 0.354840593440219, 0, 2.07222313908979, NULL, , , , 1.4127062812021, 1, 2.11386241427388, 0.498932484915801, 0, 0.776206964839883, 0.362185543371354, 0.00568688699747616, 0.718684199745232, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.125911846753007, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.26523201908741, 1.54603601603093, c(2.34782608695652, 1.74698795180723, 0, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.306772213661016, 0.135426398300959, 0.0413413504351605, 0.572203076886871, 2.26523201908741, 0.0234984452372663, 2.26523201908741, Common effect model, common, NA, 0.25454058594184, NA, 1, FALSE, FALSE
OR	8	8	0.825	1.347	2.199	.23	.60 [.14, .82]	random	Peto	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.37380660954712, -0.898720357210923, 2.88135593220339, -0.749367968408782, 0.313395219413491, 0.510435812545122, 0.0562064185176206, 0.213083622484386), c(0.415528842183368, 0.876931092336367, 1.48876715444574, 0.453165389135724, 0.287580331760914, 0.32406897670339, 0.475482940518229, 0.286867912404376), c(3.30616426606767, -1.02484718020033, 1.93539730077946, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), c(0.000945826213271411, 0.305435300635845, 0.0529415602967437, 0.0982026747675452, 0.275816308736864, 0.115237090566695, 0.905901966336454, 0.457606707594208), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, -2.61747371511357, -0.0365740718764318, -1.63755581015488, -0.250251873499981, -0.124727710300273, -0.87572302016131, -0.349167154148383), c(2.18822817476415, 0.820033000691724, 5.79928593628321, 0.138819873337315, 0.877042312326963, 1.14559933539052, 0.988135857196551, 0.775334399117154), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.314746668008182, 0.140579077288952, 2.23892967629343, 0.0251604922060862, 0.95, 0.0392167395419638, 0.5902765964744, c(2.24548288711289, 0.959985472174282, 0.401751325618803, 2.09190508959454, 2.81391519354823, 2.64763902711232, 2.00497909843707, 2.81715940417878), 0.297718673024269, 0.250134346514992, 1.19023507635895, 0.233954010322478, classic, Inf, -0.192535637441578, 0.787972983490115, 0.250134346514992, , NA, 0.286873602978349, NA, NA, NA, HTS, , NA, 0.579000415548412, 6, 0.95, -1.119044305599, 1.71448165164754, 0.286873602978349, 0.286873602978349, 17.6826776186987, 7, 0.0134867462395109, REML, NULL, QP, 0.272674289898752, 0.252945448654115, 0.0254631388347544, 4.72765914103008, 0.522182238206885, 0.159571735701391, 2.17431808644229, NULL, , , , 1.58936993889757, 1.07839074110788, 2.34246892742799, 0.604132351957954, 0.140100494594543, 0.817756384576068, 0.544762926473458, 0.158426334425372, 0.931099518521544, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.272674289898752, m4 = NULL), c(3.30616426606767, -1.02484718020033, 1.93539730077946, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), FALSE, 2.23892967629343, 1.19023507635895, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.314746668008182, 0.140579077288952, 0.0392167395419638, 0.5902765964744, 2.23892967629343, 0.0251604922060862, 2.23892967629343, Common effect model, common, NA, 0.286873602978349, NA, 1, FALSE, FALSE
OR	8	8	0.875	1.351	2.086	.18	.50 [.00, .78]	random	SSW	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 19.1566265060241, 27.3, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.300598651462804, 0.168666050539025, 1.78221195375209, 0.0747146741890535, 0.95, -0.0299807330082973, 0.631178035933905, c(40.0621118012422, 19.1566265060241, 27.3, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.300598651462804, 0.221694346015368, 1.35591482988008, 0.175126268466552, classic, Inf, -0.133914282303478, 0.735111585229086, 0.208460006832123, , NA, 0.25454058594184, NA, NA, NA, HTS, , NA, 0.411542733141354, 6, 0.95, -0.684722112511652, 1.32929546944069, 0.25454058594184, 0.25454058594184, 13.9701732586351, 7, 0.0517144010186448, REML, NULL, QP, 0.125911846753007, 0.16706379983961, 0, 4.29410873817914, 0.354840593440219, 0, 2.07222313908979, NULL, , , , 1.4127062812021, 1, 2.11386241427388, 0.498932484915801, 0, 0.776206964839883, 0.362185543371354, 0.00568688699747616, 0.718684199745232, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.125911846753007, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 1.78221195375209, 1.35591482988008, c(40.0621118012422, 19.1566265060241, 27.3, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.300598651462804, 0.168666050539025, -0.0299807330082973, 0.631178035933905, 1.78221195375209, 0.0747146741890535, 1.78221195375209, Common effect model, common, NA, 0.25454058594184, NA, 1, FALSE, FALSE
Music
OR	14	11	1.131	1.322	1.545	<.001	.00 [.00, .55]	random	GLMM	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 3.51167626991021, 0.000445290055684547, 0.95, 0.123333439204171, 0.434897768762819, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.27911560398373, 0.079482173248977, 3.51167554401668, 0.000445291271819976, classic, Inf, 0.123333407002762, 0.434897800964698, 0.080992453778062, , NA, 0.0893857598397876, NA, NA, NA, HTS, , NA, 0.079482173248977, 12, 0.95, 0.105938825179025, 0.452292382788434, 0.0893857598397876, 0.0893857598397876, c(Wald = 11.2652197985453, LRT = 24.032164114166), c(13, 13), c(0.588609949960847, 0.0308354856023768), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.4912469569957, 0, 0, 0.550322809331836, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 4.2085434045484e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.51167626991021, 3.51167554401668, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 0.123333439204171, 0.434897768762819, 3.51167626991021, 0.000445290055684547, 3.51167626991021, Common effect model, common, NA, 0.0893857598397876, NA, 1, FALSE, FALSE, list(b = 0.279115603983495, beta = 0.279115603983495, se = 0.0794821568192651, zval = 3.51167626991021, pval = 0.000445290055684547, ci.lb = 0.123333439204171, ci.ub = 0.434897768762819, vb = 0.00631741325264225, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318702246505, QMdf = c(1, NA), QMp = 0.000445290055684546, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 15, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575051403, 24.032164114166, 184.035715010281, 204.018782662909, 224.035715010281), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0259999999999536), list(b = 0.27911560398373, beta = 0.27911560398373, se = 0.079482173248977, zval = 3.51167554401668, pval = 0.000445291271819976, ci.lb = 0.123333407002762, ci.ub = 0.434897800964698, vb = 0.0063174158643804, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318651264449, QMdf = c(1, NA), QMp = 0.000445291271819976, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575054032, 24.0321641146917, 186.035715010806, 207.35098717361, 235.490260465352), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.361000000000047), 4.2-0, UM.FS
OR	14	11	1.129	1.338	1.586	<.001	.18 [.00, .56]	random	Inverse	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.302176633729435, 0.0809919579423194, 3.73094615078498, 0.00019076199875055, 0.95, 0.143435313125106, 0.460917954333764, c(5.08574141431885, 0.426841743094609, 5.54006009195956, 35.0047458574017, 22.3468107016005, 34.2031374457102, 2.49124280001788, 4.22769824582984, 10.1975359716226, 5.38621303762241, 2.63005381287484, 0.47922221620147, 0.904021040362299, 4.44760186798655), 0.291469933314328, 0.0865903343027714, 3.36607931660335, 0.00076244781457655, classic, Inf, 0.121755996671613, 0.461183869957043, 0.0865903343027714, , NA, 0.0937018761982729, NA, NA, NA, HTS, , NA, 0.112328675892893, 12, 0.95, 0.0467267731393617, 0.536213093489294, 0.0937018761982729, 0.0937018761982729, 15.8340645411597, 13, 0.258206545975509, REML, NULL, QP, 0.0051198454331848, 0.0297960646618108, 0, 0.973306580189837, 0.0715530952033858, 0, 0.986563013795792, NULL, , , , 1.103632622164, 1, 1.50174648377856, 0.178985284150679, 0, 0.556588704178558, 0.0487741805473784, 0, 0.446644488183818, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0051198454331848, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.73094615078498, 3.36607931660335, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.302176633729435, 0.0809919579423194, 0.143435313125106, 0.460917954333764, 3.73094615078498, 0.00019076199875055, 3.73094615078498, Common effect model, common, NA, 0.0937018761982729, NA, 1, FALSE, FALSE
OR	14	11	1.129	1.338	1.586	<.001	.18 [.00, .56]	random	MH	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 13, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.281497795204889, 0.0798395663178443, 3.52579313976025, 0.000422216619785514, 0.95, 0.125015120680617, 0.437980469729161, c(5.08574141431885, 0.426841743094609, 5.54006009195956, 35.0047458574017, 22.3468107016005, 34.2031374457102, 2.49124280001788, 4.22769824582984, 10.1975359716226, 5.38621303762241, 2.63005381287484, 0.47922221620147, 0.904021040362299, 4.44760186798655), 0.291469933314328, 0.0865903343027714, 3.36607931660335, 0.00076244781457655, classic, Inf, 0.121755996671613, 0.461183869957043, 0.0865903343027714, , NA, 0.0937018761982729, NA, NA, NA, HTS, , NA, 0.112328675892893, 12, 0.95, 0.0467267731393617, 0.536213093489294, 0.0937018761982729, 0.0937018761982729, 15.8340645411597, 13, 0.258206545975509, REML, NULL, QP, 0.0051198454331848, 0.0297960646618108, 0, 0.973306580189837, 0.0715530952033858, 0, 0.986563013795792, NULL, , , , 1.103632622164, 1, 1.50174648377856, 0.178985284150679, 0, 0.556588704178558, 0.0487741805473784, 0, 0.446644488183818, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0051198454331848, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.52579313976025, 3.36607931660335, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.281497795204889, 0.0798395663178443, 0.125015120680617, 0.437980469729161, 3.52579313976025, 0.000422216619785514, 3.52579313976025, Common effect model, common, NA, 0.0937018761982729, NA, 1, FALSE, FALSE
OR	14	11	1.028	1.281	1.595	.03	.44 [.00, .70]	random	Peto	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, -0.100526663026663, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, -1.15406139984312, -0.660637623336967, 0.0562064185176206), c(0.540780565579624, 1.32219331813667, 0.417348609294271, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 0.854369065122966, 0.763018377649432, 0.475482940518229), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -1.35077620077105, -0.86582137821128, 0.118209116937741), c(0.10990091605911, 0.00351376944795559, 0.809656053389246, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.176767133978651, 0.386588123690052, 0.905901966336454), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -0.918514906241311, 0.126119628474816, -0.109459222670617, 0.15271233326912, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, -2.82859399698928, -2.15612616307204, -0.87572302016131), c(1.92442314671454, 6.45067458511826, 0.717461580187986, 0.761269452833273, 0.727504996658277, 0.801769440950646, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 0.520471197303052, 0.834850916398102, 0.988135857196551), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.295032819636713, 0.0838592052098987, 3.5181924142764, 0.000434497191994632, 0.95, 0.130671797653158, 0.459393841620268, c(3.02649570047372, 0.559858161879779, 4.71361531326968, 15.5701243997845, 11.9674110212028, 15.2933563025297, 2.5587986394901, 3.10769466903825, 8.94646173355631, 4.25063544353228, 3.07487137673676, 1.30222234024674, 1.61246483217072, 3.78708197402359), 0.247484394638124, 0.111963697351824, 2.21039855320651, 0.0270775141306681, classic, Inf, 0.0280395802526055, 0.466929209023642, 0.111963697351824, , NA, 0.135741059377412, NA, NA, NA, HTS, , NA, 0.224738490748609, 12, 0.95, -0.242178712324995, 0.737147501601243, 0.135741059377412, 0.135741059377412, 23.2160677006826, 13, 0.0391552694935494, REML, NULL, QP, 0.0379715196992717, 0.0559587974295625, 0, 2.1270664145403, 0.194862822773539, 0, 1.45844657582659, NULL, , , , 1.33635749767454, 1, 1.82797072815444, 0.440042983695392, 0, 0.700731142219227, 0.216359256272469, 0, 0.453318737003278, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0379715196992717, m4 = NULL), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, -1.35077620077105, -0.86582137821128, 0.118209116937741), FALSE, 3.5181924142764, 2.21039855320651, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.295032819636713, 0.0838592052098987, 0.130671797653158, 0.459393841620268, 3.5181924142764, 0.000434497191994632, 3.5181924142764, Common effect model, common, NA, 0.135741059377412, NA, 1, FALSE, FALSE
OR	14	11	1.133	1.351	1.613	<.001	.18 [.00, .56]	random	SSW	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.301191878499216, 0.085254694133424, 3.53284803330418, 0.000411108711881327, 0.95, 0.134095748484727, 0.468288008513706, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.301191878499216, 0.0901752550570131, 3.34007237693743, 0.000837565585693265, classic, Inf, 0.124451626290757, 0.477932130707675, 0.0865903343027714, , NA, 0.0937018761982729, NA, NA, NA, HTS, , NA, 0.112328675892893, 12, 0.95, 0.0467267731393617, 0.536213093489294, 0.0937018761982729, 0.0937018761982729, 15.8340645411597, 13, 0.258206545975509, REML, NULL, QP, 0.0051198454331848, 0.0297960646618108, 0, 0.973306580189837, 0.0715530952033858, 0, 0.986563013795792, NULL, , , , 1.103632622164, 1, 1.50174648377856, 0.178985284150679, 0, 0.556588704178558, 0.0487741805473784, 0, 0.446644488183818, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0051198454331848, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.53284803330418, 3.34007237693743, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.301191878499216, 0.085254694133424, 0.134095748484727, 0.468288008513706, 3.53284803330418, 0.000411108711881327, 3.53284803330418, Common effect model, common, NA, 0.0937018761982729, NA, 1, FALSE, FALSE

Excluding Peterson 1977 and Peterson 1983

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	10	9	0.95	1.175	1.453	.14	.31 [.00, .67]	random	GLMM	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.257999999999981), 4.2-0, UM.FS
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	Inverse	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 2.00710339976287, 0.0447386543136591, 0.95, 0.00512777382132965, 0.431533233590776, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 2.00710339976287, 0.94532892002845, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 0.00512777382132965, 0.431533233590776, 2.00710339976287, 0.0447386543136591, 2.00710339976287, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	MH	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 10, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, 1.48226068135845, 0.138270945925028, 0.95, -0.0515708594286942, 0.371608241317837, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48226068135845, 0.94532892002845, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, -0.0515708594286942, 0.371608241317837, 1.48226068135845, 0.138270945925028, 1.48226068135845, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.704	1.055	1.58	.80	.52 [.00, .76]	random	Peto	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.690261338333529, 1.00795306164762, -0.358939974457216, -0.103975776405053, -0.96814727649067, 0.288825505247073, 0.0676634264671485, -1.15352537697584, -1.24149907767122, 0.510435812545122), c(0.919851510749532, 0.295964545973394, 0.4779292284239, 0.39928626800966, 0.618795351373702, 0.379240441958542, 0.171431799285525, 0.986041272695215, 1.26445115535852, 0.32406897670339), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), c(0.453010712212803, 0.000660055934616421, 0.452633611523925, 0.794552090065137, 0.117684285849375, 0.446305096005573, 0.693067336878847, 0.242059299632813, 0.326174643421658, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-2.49313717052737, 0.427873210839015, -1.29566404932708, -0.886562481225394, -2.18096387898393, -0.454472102472721, -0.26833672593738, -3.0861307587285, -3.71977780238397, -0.124727710300273), c(1.11261449386031, 1.58803291245622, 0.577784100412645, 0.678610928415287, 0.244669326002593, 1.03212311296687, 0.403663578871677, 0.779080004776819, 1.23677964704154, 1.14559933539052), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, 1.4884732078, 0.136626142703563, 0.95, -0.0533805713994409, 0.390420251770235, c(0.960198499794839, 3.53457387542192, 2.35993284854623, 2.81885438124734, 1.729409020091, 2.94856665294313, 4.45011319425951, 0.856456286477261, 0.557363504168402, 3.32950190940788), 0.0534179929825893, 0.20608715679561, 0.259200979882349, 0.795480175097968, classic, Inf, -0.350505412013065, 0.457341397978243, 0.20608715679561, , NA, 0.20687983499037, NA, NA, NA, HTS, , NA, 0.48764376290358, 8, 0.95, -1.07109054077959, 1.17792652674476, 0.20687983499037, 0.20687983499037, 18.5750500735711, 9, 0.0290586285493781, REML, NULL, QP, 0.195324523302665, 0.183532166741211, 0, 1.40213305779073, 0.441955340846408, 0, 1.18411699497589, NULL, , , , 1.43662606568968, 1.00221052340108, 2.05934222843223, 0.515479098879774, 0.00440643064809634, 0.764200462066889, 0.459891007509119, 0.0309646561078429, 0.888817358910395, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.195324523302665, m4 = NULL), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), FALSE, 1.4884732078, 0.259200979882349, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, -0.0533805713994409, 0.390420251770235, 1.4884732078, 0.136626142703563, 1.4884732078, Common effect model, common, NA, 0.20687983499037, NA, 1, FALSE, FALSE
OR	10	9	0.799	1.155	1.669	.44	.37 [.00, .70]	random	SSW	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, 1.28169151418932, 0.199950882897494, 0.95, -0.0761882335636568, 0.364125063401724, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.188002448932881, 0.765779465832555, 0.443807534315363, classic, Inf, -0.224509613994744, 0.512446443832811, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.28169151418932, 0.765779465832555, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, -0.0761882335636568, 0.364125063401724, 1.28169151418932, 0.199950882897494, 1.28169151418932, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
Art
OR	9	9	1.036	1.335	1.721	.03	.36 [.00, .71]	random	GLMM	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999959), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.222999999999956), 4.2-0, UM.FS
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	Inverse	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 2.36328689542623, 0.0181136409332486, 0.95, 0.0551492824997776, 0.591149616501597, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.36328689542623, 2.36320065200989, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 0.0551492824997776, 0.591149616501597, 2.36328689542623, 0.0181136409332486, 2.36328689542623, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	MH	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 2.2621762204149, 0.023686517892065, 0.95, 0.0396402762420969, 0.553805518736806, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.2621762204149, 2.36320065200989, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 0.0396402762420969, 0.553805518736806, 2.2621762204149, 0.023686517892065, 2.2621762204149, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	0.865	1.33	2.043	.19	.55 [.05, .79]	random	Peto	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.37380660954712, -0.898720357210923, 2.88135593220339, 0.146763960036387, -0.749367968408782, 0.313395219413491, 0.510435812545122, 0.0562064185176206, 0.213083622484386), c(0.415528842183368, 0.876931092336367, 1.48876715444574, 0.565457624206178, 0.453165389135724, 0.287580331760914, 0.32406897670339, 0.475482940518229, 0.286867912404376), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), c(0.000945826213271411, 0.305435300635845, 0.0529415602967437, 0.795211681566248, 0.0982026747675452, 0.275816308736864, 0.115237090566695, 0.905901966336454, 0.457606707594208), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, -2.61747371511357, -0.0365740718764318, -0.961512618191306, -1.63755581015488, -0.250251873499981, -0.124727710300273, -0.87572302016131, -0.349167154148383), c(2.18822817476415, 0.820033000691724, 5.79928593628321, 1.25504053826408, 0.138819873337315, 0.877042312326963, 1.14559933539052, 0.988135857196551, 0.775334399117154), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 2.23540959240253, 0.0253904709368229, 0.95, 0.0375779984132761, 0.572358887262285, c(2.63328804460967, 1.02448804204668, 0.412623508509967, 1.89814020605396, 2.42454795983714, 3.45075570522832, 3.20400013509703, 2.30854553951527, 3.45563580607993), 0.284955293439964, 0.219201151428492, 1.29997169988828, 0.193610668850246, classic, Inf, -0.14467106872959, 0.714581655609518, 0.219201151428492, , NA, 0.248402616236765, NA, NA, NA, HTS, , NA, 0.505112158473251, 7, 0.95, -0.909445166260264, 1.47935575314019, 0.248402616236765, 0.248402616236765, 17.7657933508844, 8, 0.0230525678308733, REML, NULL, QP, 0.20708914784993, 0.203168694400191, 0.00314061140378238, 3.42467830718788, 0.455070486683031, 0.0560411581231365, 1.85058863802518, NULL, , , , 1.49020943791823, 1.02473642222004, 2.16711743694, 0.549696439556878, 0.0476958985820897, 0.787070856624646, 0.478882723477907, 0.0968404089229942, 0.860925038032819, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.20708914784993, m4 = NULL), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), FALSE, 2.23540959240253, 1.29997169988828, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 0.0375779984132761, 0.572358887262285, 2.23540959240253, 0.0253904709368229, 2.23540959240253, Common effect model, common, NA, 0.248402616236765, NA, 1, FALSE, FALSE
OR	9	9	0.974	1.339	1.839	.07	.43 [.00, .74]	random	SSW	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, 1.79950836241973, 0.0719383023115588, 0.95, -0.0260037780075166, 0.609268052087494, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162065287495661, 1.79947317248795, 0.0719438639077346, classic, Inf, -0.0260099895956367, 0.609274263675614, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 1.79950836241973, 1.79947317248795, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, -0.0260037780075166, 0.609268052087494, 1.79950836241973, 0.0719383023115588, 1.79950836241973, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
Music
OR	15	12	1.142	1.334	1.558	<.001	.02 [.00, .55]	random	GLMM	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0269999999999868), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.413000000000011), 4.2-0, UM.FS
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	Inverse	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 3.88401281096207, 0.000102746490259109, 0.95, 0.155324355220281, 0.471771773781667, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.88401281096207, 3.82062176216205, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 0.155324355220281, 0.471771773781667, 3.88401281096207, 0.000102746490259109, 3.88401281096207, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	MH	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 14, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 3.64677076815372, 0.000265556628429634, 0.95, 0.134154570578494, 0.44591301173438, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.64677076815372, 3.82062176216205, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 0.134154570578494, 0.44591301173438, 3.64677076815372, 0.000265556628429634, 3.64677076815372, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.048	1.304	1.623	.02	.50 [.10, .73]	random	Peto	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, -0.100526663026663, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, 3.80987443815582, -1.15406139984312, -0.660637623336967, 0.0562064185176206), c(0.540780565579624, 1.32219331813667, 0.417348609294271, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 1.57151003840543, 0.854369065122966, 0.763018377649432, 0.475482940518229), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), c(0.10990091605911, 0.00351376944795559, 0.809656053389246, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.0153362452313665, 0.176767133978651, 0.386588123690052, 0.905901966336454), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -0.918514906241311, 0.126119628474816, -0.109459222670617, 0.15271233326912, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, 0.729771361538017, -2.82859399698928, -2.15612616307204, -0.87572302016131), c(1.92442314671454, 6.45067458511826, 0.717461580187986, 0.761269452833273, 0.727504996658277, 0.801769440950646, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 6.88997751477362, 0.520471197303052, 0.834850916398102, 0.988135857196551), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 3.64237828972792, 0.00027013070886894, 0.95, 0.140885481768204, 0.469140501187361, c(3.02812775867362, 0.559913985849404, 4.71757530577234, 15.6134167757432, 11.9929702856244, 15.3351211986603, 2.55996515777787, 3.10941550109688, 8.96073806023234, 4.25385545912247, 3.07655604025104, 0.398813571428646, 1.30252439967449, 1.61292798744651, 3.78963775592615), 0.265293388296449, 0.111586324076742, 2.37747224394629, 0.0174317548328194, classic, Inf, 0.0465882119388207, 0.483998564654077, 0.111586324076742, , NA, 0.146574865323034, NA, NA, NA, HTS, , NA, 0.224153841952073, 13, 0.95, -0.218961546082525, 0.749548322675422, 0.146574865323034, 0.146574865323034, 28.2042497518316, 14, 0.013365314539765, REML, NULL, QP, 0.0377934371409155, 0.0558193149766794, 0.0153224119366302, 3.4330894889523, 0.194405342367219, 0.123783730500539, 1.85285981362657, NULL, , , , 1.41936227510385, 1.05509731292569, 1.90938716581667, 0.503620903828834, 0.101713307390774, 0.725708719562553, 0.20234999106332, 0.0267758214048096, 0.37792416072183, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0377934371409155, m4 = NULL), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), FALSE, 3.64237828972792, 2.37747224394629, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 0.140885481768204, 0.469140501187361, 3.64237828972792, 0.00027013070886894, 3.64237828972792, Common effect model, common, NA, 0.146574865323034, NA, 1, FALSE, FALSE
OR	15	12	1.147	1.357	1.606	<.001	.26 [.00, .60]	random	SSW	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 3.58778867043299, 0.000333494416493596, 0.95, 0.138507650203251, 0.472044803600983, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0858781448081737, 3.55476038267959, 0.000378323701918848, classic, Inf, 0.136958156018981, 0.473594297785252, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.58778867043299, 3.55476038267959, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 0.138507650203251, 0.472044803600983, 3.58778867043299, 0.000333494416493596, 3.58778867043299, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE

From raw proportions, using glmer()

With glmer, any number of variables can be modeled as random effects.

The model type “random” treats only each estimate as a random effect.

The model type “random (all) includes study, estimate, handedness comparison, and population (Students/Faculty/Professionals) as random effects. Because estimates might vary along all of these variables, I think it makes sense to use this model for the published analysis.

All studies

From raw proportions, with all random effects, using glmer()
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	10	9	0.934	1.151	1.418	.19	.31 [.00, .67]	random	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.257999999999981), 4.2-0, UM.FS
OR	10	9	0.934	1.151	1.42	.19	.31 [.00, .67]	random (all)	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.25200000000001), 4.2-0, UM.FS
Art
OR	9	9	1.02	1.309	1.68	.03	.36 [.00, .71]	random	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0179999999999723), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.211999999999989), 4.2-0, UM.FS
OR	9	9	1.019	1.309	1.68	.03	.36 [.00, .71]	random (all)	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.02800000000002), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.225000000000023), 4.2-0, UM.FS
Music
OR	15	12	1.129	1.317	1.537	<.001	.02 [.00, .55]	random	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000387), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.391999999999996), 4.2-0, UM.FS
OR	15	12	1.136	1.324	1.543	<.001	.02 [.00, .55]	random (all)	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.394000000000005), 4.2-0, UM.FS

Excluding Cosenza 1993

From raw proportions, with all random effects, using glmer(), excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	9	8	0.925	1.217	1.602	.16	.30 [.00, .67]	random	glmer	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, 1.63466651027623, 0.102118976648984, 0.95, -0.0467099344460416, 0.516158187672964, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613223, 0.14359149447742, 1.63466594917385, 0.10211909433794, classic, Inf, -0.0467100310488014, 0.516158284275248, 0.197875579865113, , NA, 0.203572685665658, NA, NA, NA, HTS, , NA, 0.14359149447742, 7, 0.95, -0.104815803550535, 0.574264056776982, 0.203572685665658, 0.203572685665658, c(Wald = 11.3898392511646, LRT = 18.9345999102618), c(8, 8), c(0.180573381004509, 0.0152133477543868), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.19320153636994, 1, 1.75311033794514, 0.297619586757382, 0, 0.674627009820718, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0960086613447547, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.63466651027623, 1.63466594917385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, -0.0467099344460416, 0.516158187672964, 1.63466651027623, 0.102118976648984, 1.63466651027623, Common effect model, common, NA, 0.203572685665658, NA, 1, FALSE, FALSE, list(b = 0.234724126613461, beta = 0.234724126613461, se = 0.143591445189513, zval = 1.63466651027623, pval = 0.102118976648984, ci.lb = -0.0467099344460416, ci.ub = 0.516158187672964, vb = 0.0206185031316129, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213459981865, QMdf = c(1, NA), QMp = 0.102118976648984, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628195841, 18.9345999102618, 115.868325639168, 124.77204321813, 147.29689706774), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.234724126613223, beta = 0.234724126613223, se = 0.14359149447742, zval = 1.63466594917385, pval = 0.10211909433794, ci.lb = -0.0467100310488014, ci.ub = 0.516158284275248, vb = 0.0206185172862589, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213276538845, QMdf = c(1, NA), QMp = 0.10211909433794, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628198105, 18.9345999107145, 117.868325639621, 127.662414976479, 161.868325639621), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.199000000000069), 4.2-0, UM.FS
OR	9	8	0.923	1.218	1.607	.16	.30 [.00, .67]	random (all)	glmer	c(1, 26, 7, 9, 1, 12, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.68115534870142, 1, 0.101542034856165, FALSE, c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, 1.63466651027623, 0.102118976648984, 0.95, -0.0467099344460416, 0.516158187672964, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613223, 0.14359149447742, 1.63466594917385, 0.10211909433794, classic, Inf, -0.0467100310488014, 0.516158284275248, 0.197875579865113, , NA, 0.203572685665658, NA, NA, NA, HTS, , NA, 0.14359149447742, 7, 0.95, -0.104815803550535, 0.574264056776982, 0.203572685665658, 0.203572685665658, c(Wald = 11.3898392511646, LRT = 18.9345999102618), c(8, 8), c(0.180573381004509, 0.0152133477543868), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.19320153636994, 1, 1.75311033794514, 0.297619586757382, 0, 0.674627009820718, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0960086613447547, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.63466651027623, 1.63466594917385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.234724126613461, 0.143591445189513, -0.0467099344460416, 0.516158187672964, 1.63466651027623, 0.102118976648984, 1.63466651027623, Common effect model, common, NA, 0.203572685665658, NA, 1, FALSE, FALSE, list(b = 0.234724126613461, beta = 0.234724126613461, se = 0.143591445189513, zval = 1.63466651027623, pval = 0.102118976648984, ci.lb = -0.0467099344460416, ci.ub = 0.516158187672964, vb = 0.0206185031316129, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213459981865, QMdf = c(1, NA), QMp = 0.102118976648984, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628195841, 18.9345999102618, 115.868325639168, 124.77204321813, 147.29689706774), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.234724126613223, beta = 0.234724126613223, se = 0.14359149447742, zval = 1.63466594917385, pval = 0.10211909433794, ci.lb = -0.0467100310488014, ci.ub = 0.516158284275248, vb = 0.0206185172862589, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.210872234481062, QE.Wld = 11.3898392511646, QEp.Wld = 0.180573381004509, QE.LRT = 18.9345999102618, QEp.LRT = 0.0152133477543868, QE.df = 8, QM = 2.67213276538845, QMdf = c(1, NA), QMp = 0.10211909433794, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 5477, 6094, 716), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-47.9341628198105, 18.9345999107145, 117.868325639621, 127.662414976479, 161.868325639621), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.211000000000013), 4.2-0, UM.FS
Art
OR	8	8	1.025	1.327	1.719	.03	.44 [.00, .75]	random	glmer	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 2.23601771732356, 0.0253506106201736, 0.95, 0.036909551002931, 0.561020490723652, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863291, 0.133704231109007, 2.23601765167438, 0.0253506149203079, classic, Inf, 0.0369095433090169, 0.561020498417565, 0.141408063317076, , NA, 0.199766622478753, NA, NA, NA, HTS, , NA, 0.133704231109007, 6, 0.95, -0.0281974467855646, 0.626127488512146, 0.199766622478753, 0.199766622478753, c(Wald = 12.4208321157769, LRT = 19.4242668574118), c(7, 7), c(0.0875415589706421, 0.00695718956281426), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.33206778655147, 1, 2.00247657038577, 0.436430672699567, 0, 0.750617994479567, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 4.69439976702832e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23601771732356, 2.23601765167438, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 0.036909551002931, 0.561020490723652, 2.23601771732356, 0.0253506106201736, 2.23601771732356, Common effect model, common, NA, 0.199766622478753, NA, 1, FALSE, FALSE, list(b = 0.298965020863292, beta = 0.298965020863292, se = 0.133704227183469, zval = 2.23601771732356, pval = 0.0253506106201736, ci.lb = 0.036909551002931, ci.ub = 0.561020490723652, vb = 0.0178768203667287, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977523218488, QMdf = c(1, NA), QMp = 0.0253506106201736, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856284012, 19.4242668574118, 106.546771256802, 113.50006975696, 136.546771256802), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0170000000000528), list(b = 0.298965020863291, beta = 0.298965020863291, se = 0.133704231109007, zval = 2.23601765167438, pval = 0.0253506149203079, ci.lb = 0.0369095433090169, ci.ub = 0.561020498417565, vb = 0.0178768214164508, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977493859941, QMdf = c(1, NA), QMp = 0.025350614920308, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856285378, 19.4242668576848, 108.546771257076, 116.272658479473, 152.546771257076), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.17999999999995), 4.2-0, UM.FS
OR	8	8	1.025	1.327	1.719	.03	.44 [.00, .75]	random (all)	glmer	c(21, 1, 2, 2, 19, 18, 6, 28), c(75, 30, 42, 43, 78, 147, 100, 225), c(7, 5, 0, 722, 1184, 46, 25, 27), c(86, 53, 78, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.02319978601476, 1, 0.0250099113909202, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 2.23601771732356, 0.0253506106201736, 0.95, 0.036909551002931, 0.561020490723652, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863291, 0.133704231109007, 2.23601765167438, 0.0253506149203079, classic, Inf, 0.0369095433090169, 0.561020498417565, 0.141408063317076, , NA, 0.199766622478753, NA, NA, NA, HTS, , NA, 0.133704231109007, 6, 0.95, -0.0281974467855646, 0.626127488512146, 0.199766622478753, 0.199766622478753, c(Wald = 12.4208321157769, LRT = 19.4242668574118), c(7, 7), c(0.0875415589706421, 0.00695718956281426), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.33206778655147, 1, 2.00247657038577, 0.436430672699567, 0, 0.750617994479567, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art" ), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 4.69439976702832e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23601771732356, 2.23601765167438, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.298965020863292, 0.133704227183469, 0.036909551002931, 0.561020490723652, 2.23601771732356, 0.0253506106201736, 2.23601771732356, Common effect model, common, NA, 0.199766622478753, NA, 1, FALSE, FALSE, list(b = 0.298965020863292, beta = 0.298965020863292, se = 0.133704227183469, zval = 2.23601771732356, pval = 0.0253506106201736, ci.lb = 0.036909551002931, ci.ub = 0.561020490723652, vb = 0.0178768203667287, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977523218488, QMdf = c(1, NA), QMp = 0.0253506106201736, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856284012, 19.4242668574118, 106.546771256802, 113.50006975696, 136.546771256802), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0159999999999627), list(b = 0.298965020863291, beta = 0.298965020863291, se = 0.133704231109007, zval = 2.23601765167438, pval = 0.0253506149203079, ci.lb = 0.0369095433090169, ci.ub = 0.561020498417565, vb = 0.0178768214164508, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.17729540074884, QE.Wld = 12.4208321157769, QEp.Wld = 0.0875415589706421, QE.LRT = 19.4242668574118, QEp.LRT = 0.00695718956281426, QE.df = 7, QM = 4.99977493859941, QMdf = c(1, NA), QMp = 0.025350614920308, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 5511, 6169, 716, 539, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.2733856285378, 19.4242668576848, 108.546771257076, 116.272658479473, 152.546771257076), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.191000000000031), 4.2-0, UM.FS
Music
OR	14	11	1.121	1.308	1.527	<.001	.00 [.00, .55]	random	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 3.51167626991021, 0.000445290055684547, 0.95, 0.123333439204171, 0.434897768762819, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.27911560398373, 0.079482173248977, 3.51167554401668, 0.000445291271819976, classic, Inf, 0.123333407002762, 0.434897800964698, 0.080992453778062, , NA, 0.0893857598397876, NA, NA, NA, HTS, , NA, 0.079482173248977, 12, 0.95, 0.105938825179025, 0.452292382788434, 0.0893857598397876, 0.0893857598397876, c(Wald = 11.2652197985453, LRT = 24.032164114166), c(13, 13), c(0.588609949960847, 0.0308354856023768), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.4912469569957, 0, 0, 0.550322809331836, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 4.2085434045484e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.51167626991021, 3.51167554401668, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 0.123333439204171, 0.434897768762819, 3.51167626991021, 0.000445290055684547, 3.51167626991021, Common effect model, common, NA, 0.0893857598397876, NA, 1, FALSE, FALSE, list(b = 0.279115603983495, beta = 0.279115603983495, se = 0.0794821568192651, zval = 3.51167626991021, pval = 0.000445290055684547, ci.lb = 0.123333439204171, ci.ub = 0.434897768762819, vb = 0.00631741325264225, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318702246505, QMdf = c(1, NA), QMp = 0.000445290055684546, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 15, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575051403, 24.032164114166, 184.035715010281, 204.018782662909, 224.035715010281), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000955), list(b = 0.27911560398373, beta = 0.27911560398373, se = 0.079482173248977, zval = 3.51167554401668, pval = 0.000445291271819976, ci.lb = 0.123333407002762, ci.ub = 0.434897800964698, vb = 0.0063174158643804, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318651264449, QMdf = c(1, NA), QMp = 0.000445291271819976, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575054032, 24.0321641146917, 186.035715010806, 207.35098717361, 235.490260465352), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.339999999999918), 4.2-0, UM.FS
OR	14	11	1.127	1.315	1.534	<.001	.00 [.00, .55]	random (all)	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 12.3902845964923, 1, 0.000431573470785726, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 14, 14, 14, 14, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 3.51167626991021, 0.000445290055684547, 0.95, 0.123333439204171, 0.434897768762819, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.27911560398373, 0.079482173248977, 3.51167554401668, 0.000445291271819976, classic, Inf, 0.123333407002762, 0.434897800964698, 0.080992453778062, , NA, 0.0893857598397876, NA, NA, NA, HTS, , NA, 0.079482173248977, 12, 0.95, 0.105938825179025, 0.452292382788434, 0.0893857598397876, 0.0893857598397876, c(Wald = 11.2652197985453, LRT = 24.032164114166), c(13, 13), c(0.588609949960847, 0.0308354856023768), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.4912469569957, 0, 0, 0.550322809331836, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL" ), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 4.2085434045484e-07, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.51167626991021, 3.51167554401668, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.279115603983495, 0.0794821568192651, 0.123333439204171, 0.434897768762819, 3.51167626991021, 0.000445290055684547, 3.51167626991021, Common effect model, common, NA, 0.0893857598397876, NA, 1, FALSE, FALSE, list(b = 0.279115603983495, beta = 0.279115603983495, se = 0.0794821568192651, zval = 3.51167626991021, pval = 0.000445290055684547, ci.lb = 0.123333439204171, ci.ub = 0.434897768762819, vb = 0.00631741325264225, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318702246505, QMdf = c(1, NA), QMp = 0.000445290055684546, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 15, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575051403, 24.032164114166, 184.035715010281, 204.018782662909, 224.035715010281), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0289999999999964), list(b = 0.27911560398373, beta = 0.27911560398373, se = 0.079482173248977, zval = 3.51167554401668, pval = 0.000445291271819976, ci.lb = 0.123333407002762, ci.ub = 0.434897800964698, vb = 0.0063174158643804, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.105389035465611, QE.Wld = 11.2652197985453, QEp.Wld = 0.588609949960847, QE.LRT = 24.032164114166, QEp.LRT = 0.0308354856023768, QE.df = 13, QM = 12.3318651264449, QMdf = c(1, NA), QMp = 0.000445291271819976, k = 14, k.f = 14, k.yi = 14, k.eff = 28, k.all = 14, p = 1, p.eff = 15, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 5480, 6101, 539), ids = 1:14, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:14, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-77.0178575054032, 24.0321641146917, 186.035715010806, 207.35098717361, 235.490260465352), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.379000000000019), 4.2-0, UM.FS

Excluding Peterson 1977 and Peterson 1983

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	10	9	0.934	1.151	1.418	.19	.31 [.00, .67]	random	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0769999999999982), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.630999999999972), 4.2-0, UM.FS
OR	10	9	0.934	1.151	1.42	.19	.31 [.00, .67]	random (all)	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.24899999999991), 4.2-0, UM.FS
Art
OR	9	9	1.02	1.309	1.68	.03	.36 [.00, .71]	random	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0319999999999254), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.442000000000007), 4.2-0, UM.FS
OR	9	9	1.019	1.309	1.68	.03	.36 [.00, .71]	random (all)	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.201000000000022), 4.2-0, UM.FS
Music
OR	15	12	1.129	1.317	1.537	<.001	.02 [.00, .55]	random	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.04099999999994), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.504999999999995), 4.2-0, UM.FS
OR	15	12	1.136	1.324	1.543	<.001	.02 [.00, .55]	random (all)	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.375), 4.2-0, UM.FS

All methods

All studies, including Cosenza 1993, Peterson 1979, and Peterson 1983.

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	10	9	0.95	1.175	1.453	.14	.31 [.00, .67]	random	GLMM	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.240000000000009), 4.2-0, UM.FS
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	Inverse	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 2.00710339976287, 0.0447386543136591, 0.95, 0.00512777382132965, 0.431533233590776, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 2.00710339976287, 0.94532892002845, c(0.789709841459767, 16.9148492202111, 4.05100590830903, 6.00602412872951, 0.915926971958846, 7.74151473195223, 35.6673228567869, 0.474640453598307, 0.449787734139478, 11.4997159175123), 0.218330503706053, 0.108778901840258, 0.00512777382132965, 0.431533233590776, 2.00710339976287, 0.0447386543136591, 2.00710339976287, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.841	1.175	1.64	.34	.37 [.00, .70]	random	MH	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 10, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, 1.48226068135845, 0.138270945925028, 0.95, -0.0515708594286942, 0.371608241317837, c(0.736564077379245, 6.64509643351896, 2.95665960499045, 3.87797184119202, 0.84519611632862, 4.53430550227124, 8.37492032780325, 0.454912449764716, 0.432032963638894, 5.60770963902656), 0.161024321645839, 0.170336819528374, 0.94532892002845, 0.344490978241816, classic, Inf, -0.172829709870873, 0.494878353162551, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48226068135845, 0.94532892002845, c(1.44736842105263, 9.21602787456446, 5.04761904761905, 6.46153846153846, 3.25, 6.38524590163934, 33.7032222119045, 1.1864159211247, 0.776501476862488, 8.2877094972067), 0.160018690944572, 0.107955835945077, -0.0515708594286942, 0.371608241317837, 1.48226068135845, 0.138270945925028, 1.48226068135845, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.704	1.055	1.58	.80	.52 [.00, .76]	random	Peto	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.690261338333529, 1.00795306164762, -0.358939974457216, -0.103975776405053, -0.96814727649067, 0.288825505247073, 0.0676634264671485, -1.15352537697584, -1.24149907767122, 0.510435812545122), c(0.919851510749532, 0.295964545973394, 0.4779292284239, 0.39928626800966, 0.618795351373702, 0.379240441958542, 0.171431799285525, 0.986041272695215, 1.26445115535852, 0.32406897670339), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), c(0.453010712212803, 0.000660055934616421, 0.452633611523925, 0.794552090065137, 0.117684285849375, 0.446305096005573, 0.693067336878847, 0.242059299632813, 0.326174643421658, 0.115237090566695), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-2.49313717052737, 0.427873210839015, -1.29566404932708, -0.886562481225394, -2.18096387898393, -0.454472102472721, -0.26833672593738, -3.0861307587285, -3.71977780238397, -0.124727710300273), c(1.11261449386031, 1.58803291245622, 0.577784100412645, 0.678610928415287, 0.244669326002593, 1.03212311296687, 0.403663578871677, 0.779080004776819, 1.23677964704154, 1.14559933539052), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, 1.4884732078, 0.136626142703563, 0.95, -0.0533805713994409, 0.390420251770235, c(0.960198499794839, 3.53457387542192, 2.35993284854623, 2.81885438124734, 1.729409020091, 2.94856665294313, 4.45011319425951, 0.856456286477261, 0.557363504168402, 3.32950190940788), 0.0534179929825893, 0.20608715679561, 0.259200979882349, 0.795480175097968, classic, Inf, -0.350505412013065, 0.457341397978243, 0.20608715679561, , NA, 0.20687983499037, NA, NA, NA, HTS, , NA, 0.48764376290358, 8, 0.95, -1.07109054077959, 1.17792652674476, 0.20687983499037, 0.20687983499037, 18.5750500735711, 9, 0.0290586285493781, REML, NULL, QP, 0.195324523302665, 0.183532166741211, 0, 1.40213305779073, 0.441955340846408, 0, 1.18411699497589, NULL, , , , 1.43662606568968, 1.00221052340108, 2.05934222843223, 0.515479098879774, 0.00440643064809634, 0.764200462066889, 0.459891007509119, 0.0309646561078429, 0.888817358910395, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.195324523302665, m4 = NULL), c(-0.750405179821987, 3.40565474939768, -0.751031644666129, -0.260404087832387, -1.56456779182555, 0.761589412129858, 0.39469588926412, -1.16985506481167, -0.981848189556368, 1.57508385325112), FALSE, 1.4884732078, 0.259200979882349, c(1.18185595567867, 11.4161750967902, 4.37797036622868, 6.27236396391824, 2.61159552095632, 6.95297570619181, 34.0264963846463, 1.02851306508322, 0.6254547351892, 9.5219321922109), 0.168519840185397, 0.113216576087704, -0.0533805713994409, 0.390420251770235, 1.4884732078, 0.136626142703563, 1.4884732078, Common effect model, common, NA, 0.20687983499037, NA, 1, FALSE, FALSE
OR	10	9	0.799	1.155	1.669	.44	.37 [.00, .70]	random	SSW	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, 1.28169151418932, 0.199950882897494, 0.95, -0.0761882335636568, 0.364125063401724, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.188002448932881, 0.765779465832555, 0.443807534315363, classic, Inf, -0.224509613994744, 0.512446443832811, 0.170336819528374, , NA, 0.16735776534832, NA, NA, NA, HTS, , NA, 0.346960928211528, 8, 0.95, -0.639069013564221, 0.961117656855899, 0.16735776534832, 0.16735776534832, 14.315993467232, 9, 0.111520367483052, REML, NULL, QP, 0.0913672536183633, 0.115097707315932, 0, 1.11495131161323, 0.302270166603261, 0, 1.05591254922613, NULL, , , , 1.26121605635337, 1, 1.82677247076702, 0.371332487640473, 0, 0.700338407233097, 0.314900610644545, 0, 0.744352278053933, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0913672536183633, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.28169151418932, 0.765779465832555, c(16.0394736842105, 123.682055749129, 35.5102040816327, 57.6521739130435, 22.8579545454545, 55.9918032786885, 335.818924691243, 8.98521088186964, 3.99737446668855, 116.819832402235), 0.143968414919034, 0.112326884687299, -0.0761882335636568, 0.364125063401724, 1.28169151418932, 0.199950882897494, 1.28169151418932, Common effect model, common, NA, 0.16735776534832, NA, 1, FALSE, FALSE
OR	10	9	0.934	1.151	1.418	.19	.31 [.00, .67]	random	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.257999999999981), 4.2-0, UM.FS
OR	10	9	0.934	1.151	1.42	.19	.31 [.00, .67]	random (all)	glmer	c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 2.21916047032304, 1, 0.136307162499356, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), OR, 0, c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182624, -1.06199361583117, -0.774936080139642, 0.46149942111032), c(1.1252945742284, 0.243145331083503, 0.49684229786825, 0.408043499640472, 1.04488760145009, 0.359407410726177, 0.167442131374939, 1.4515019540099, 1.49106369527854, 0.294887554610119), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), c(0.461156259021663, 0.000860464704901891, 0.452833053467925, 0.794287372697252, 0.149782462242316, 0.446737306426713, 0.693104702687077, 0.464381291726889, 0.603258531721447, 0.117582592730875), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.03481619237053, 0.33374380595198, -1.34677266278157, -0.906146811952367, -3.55289397165582, -0.430964821071397, -0.262100302671242, -3.90688516918009, -3.6973672215408, -0.1164695654146), c(1.37625748260147, 1.28685598981745, 0.600813356854215, 0.69335431488965, 0.542990161813405, 0.977886340528807, 0.394260791307767, 1.78289793751774, 2.14749506126151, 1.03946840763524), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, 1.48841982692824, 0.13664021101152, 0.95, -0.0510906805186919, 0.373624129943292, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.161266724712285, 0.108347614341445, 1.48841970995385, 0.136640241840865, classic, Inf, -0.0510906972077828, 0.373624146632353, 0.152973386202799, , NA, 0.160148613561488, NA, NA, NA, HTS, , NA, 0.108347614341445, 8, 0.95, -0.0885833219985936, 0.411116771423164, 0.160148613561488, 0.160148613561488, c(Wald = 13.0808959859307, LRT = 19.5242305997346), c(9, 9), c(0.158979841853623, 0.021086614721034), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.20558404407392, 1, 1.74447526969816, 0.311973735615661, 0, 0.671397876382807, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(7, 12, 14, 18, 19, 29, 36, 41, 47, 54), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Students", "Students", "Professionals", "Professionals", "Students"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (M)", "Architecture students (W)", "Architecture", "Architecture applicants", "Architects, except naval", "Architects, except naval", "Design, Arch., Art"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (M)", "General students (W)", "Non-architecture", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "0-split", "Writing hand", "0-split", "EHI", "1i_2pt", "3i_3pt", "Drawing hand"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n_left_creative = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), n_right_creative = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), n_control = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), n_left_control = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n_right_control = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), PL_creative = c(4.34782608695652, 18.4397163120567, 11.6666666666667, 11.5384615384615, 3.7037037037037, 17.3913043478261, 12.1037463976945, 0, 0, 12.2448979591837), PL_control = c(9.43396226415094, 9.13604766633565, 16.0919540229885, 12.6696832579186, 14.7651006711409, 13.8047138047138, 11.4181539052005, 13.2040965618142, 19.4252873563218, 8.08435852372583), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.0639485041028121, 1.39958965745661, 0.266371689248105, 0.410096960522666, 0.0366109225183829, 0.656029435454098, 0.770193102766583, 0, 0, 0.89532149083073), effect = c(0.436363636363636, 2.24858223062382, 0.688679245283019, 0.899068322981367, 0.222027972027972, 1.31450577663671, 1.06831243972999, 0, 0, 1.58645096056623), upper = c(3.0959628184797, 3.61257460066216, 1.78764893600914, 1.97499953274194, 1.36956935286763, 2.63918495427251, 1.48182509656637, 2.81240464682898, 3.99113580499188, 2.81389813908544), chi_sq = c(0.09, 10.62, 0.26, 0, 1.58, 0.33, 0.1, 0.46, 0.12, 2), p = c(0.769973513794959, 0.00111769317670308, 0.607379457302083, 0.951468462772894, 0.208120208893935, 0.566812505144001, 0.757325835037076, 0.498471798968014, 0.726600405319471, 0.15735099029876), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "(SR+MR)/(SL+ML)", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "R/L"), pref_success = c("mix", "success", "pref", "pref", "pref", "pref", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.773487252391632, 0.564547348997558, 0.388088061505383, 0.399217175561138, 0.340046664342675, 0.505916316437775, 0.181542109807387, 0.717463348564788, 1.01816559806034, 0.489441812040476), inv_var = c(1.67145111298491, 3.13761212946032, 6.63956204965919, 6.27453526571943, 8.64814498587693, 3.90699295075821, 30.3420726125208, 1.94267682668582, 0.964635325792623, 4.17443655632658), .event.e = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), .n.e = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), .event.c = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), .n.c = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "wood_1991", "fry_1990", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.0577749108859955, m4 = NULL), c(-0.736944240092112, 3.33257436724719, -0.750700281686929, -0.260747318913558, -1.4403002799848, 0.760865668229215, 0.394645265057541, -0.731651523373652, -0.519720306109979, 1.56500135016035), FALSE, 1.48841982692824, 1.48841970995385, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.1612667247123, 0.108347605826454, -0.0510906805186919, 0.373624129943292, 1.48841982692824, 0.13664021101152, 1.48841982692824, Common effect model, common, NA, 0.160148613561488, NA, 1, FALSE, FALSE, list(b = 0.1612667247123, beta = 0.1612667247123, se = 0.108347605826454, zval = 1.48841982692824, pval = 0.13664021101152, ci.lb = -0.0510906805186919, ci.ub = 0.373624129943292, vb = 0.0117392036883246, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.2153935811931, QMdf = c(1, NA), QMp = 0.13664021101152, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044263829, 19.5242305997346, 132.707008852766, 143.66006386186, 165.707008852766), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.161266724712285, beta = 0.161266724712285, se = 0.108347614341445, zval = 1.48841970995385, pval = 0.136640241840865, ci.lb = -0.0510906972077828, ci.ub = 0.373624146632353, vb = 0.0117392055334825, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.142507971924641, QE.Wld = 13.0808959859307, QEp.Wld = 0.158979841853623, QE.LRT = 19.5242305997346, QEp.LRT = 0.021086614721034, QE.df = 9, QM = 2.21539323297909, QMdf = c(1, NA), QMp = 0.136640241840865, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.829279354884525, 0.810299897884713, -0.372979652963676, -0.106396248531358, -1.50495190492121, 0.273460759728705, 0.0660802443182626, -1.06199361583117, -0.774936080139642, 0.461499421110321), vi.f = c(1.26628787878788, 0.0591196520277062, 0.246852268951002, 0.166499497598844, 1.09179009966412, 0.129173686884895, 0.0280368673593823, 2.10685792249455, 2.22327094337771, 0.0869586698639356), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ti = NA), outdat = list(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), bi = c(22, 115, 53, 69, 26, 57, 305, 9, 4, 129), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), di = c(48, 915, 73, 193, 127, 256, 9232, 4746, 4907, 523), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ni.f = c(76, 1148, 147, 299, 176, 366, 10769, 5477, 6094, 716), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-55.3535044266092, 19.5242306001873, 134.707008853218, 146.655796135866, 179.278437424647), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(1, 26, 7, 9, 1, 12, 42, 0, 0, 18), ci = c(5, 92, 14, 28, 22, 41, 1190, 722, 1183, 46), n1i = c(23, 141, 60, 78, 27, 69, 347, 9, 4, 147), n2i = c(53, 1007, 87, 221, 149, 297, 10422, 5468, 6090, 569), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.25200000000001), 4.2-0, UM.FS
Art
OR	9	9	1.036	1.335	1.721	.03	.36 [.00, .71]	random	GLMM	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.468000000000018), 4.2-0, UM.FS
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	Inverse	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 2.36328689542623, 0.0181136409332486, 0.95, 0.0551492824997776, 0.591149616501597, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.36328689542623, 2.36320065200989, c(4.5115576371053, 0.796612109419709, 0.410268156712951, 3.4723947319704, 1.90119132548178, 14.1584667671487, 11.4997159175123, 4.55123826988389, 12.1828226441155), 0.323149449500687, 0.136737291661919, 0.0551492824997776, 0.591149616501597, 2.36328689542623, 0.0181136409332486, 2.36328689542623, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	1.057	1.381	1.806	.02	.43 [.00, .74]	random	MH	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 2.2621762204149, 0.023686517892065, 0.95, 0.0396402762420969, 0.553805518736806, c(4.51141800023208, 0.796607755785152, 0.410267001944433, 3.47231201238123, 1.90116652806046, 14.1570916148292, 11.4988087228233, 4.55109616594292, 12.1818044746144), 0.323148820343562, 0.136742015566357, 2.36320065200989, 0.0181178570807743, classic, Inf, 0.0551393946600866, 0.591158246027038, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.2621762204149, 2.36320065200989, c(2.34782608695652, 1.74698795180723, 0, 3.07375872955132, 5.37143894030122, 11.3237153509483, 8.2877094972067, 4.35992578849722, 10.9219712525667), 0.296722897489451, 0.131167012901864, 0.0396402762420969, 0.553805518736806, 2.2621762204149, 0.023686517892065, 2.2621762204149, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	0.865	1.33	2.043	.19	.55 [.05, .79]	random	Peto	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.37380660954712, -0.898720357210923, 2.88135593220339, 0.146763960036387, -0.749367968408782, 0.313395219413491, 0.510435812545122, 0.0562064185176206, 0.213083622484386), c(0.415528842183368, 0.876931092336367, 1.48876715444574, 0.565457624206178, 0.453165389135724, 0.287580331760914, 0.32406897670339, 0.475482940518229, 0.286867912404376), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), c(0.000945826213271411, 0.305435300635845, 0.0529415602967437, 0.795211681566248, 0.0982026747675452, 0.275816308736864, 0.115237090566695, 0.905901966336454, 0.457606707594208), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.559385044330094, -2.61747371511357, -0.0365740718764318, -0.961512618191306, -1.63755581015488, -0.250251873499981, -0.124727710300273, -0.87572302016131, -0.349167154148383), c(2.18822817476415, 0.820033000691724, 5.79928593628321, 1.25504053826408, 0.138819873337315, 0.877042312326963, 1.14559933539052, 0.988135857196551, 0.775334399117154), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 2.23540959240253, 0.0253904709368229, 0.95, 0.0375779984132761, 0.572358887262285, c(2.63328804460967, 1.02448804204668, 0.412623508509967, 1.89814020605396, 2.42454795983714, 3.45075570522832, 3.20400013509703, 2.30854553951527, 3.45563580607993), 0.284955293439964, 0.219201151428492, 1.29997169988828, 0.193610668850246, classic, Inf, -0.14467106872959, 0.714581655609518, 0.219201151428492, , NA, 0.248402616236765, NA, NA, NA, HTS, , NA, 0.505112158473251, 7, 0.95, -0.909445166260264, 1.47935575314019, 0.248402616236765, 0.248402616236765, 17.7657933508844, 8, 0.0230525678308733, REML, NULL, QP, 0.20708914784993, 0.203168694400191, 0.00314061140378238, 3.42467830718788, 0.455070486683031, 0.0560411581231365, 1.85058863802518, NULL, , , , 1.49020943791823, 1.02473642222004, 2.16711743694, 0.549696439556878, 0.0476958985820897, 0.787070856624646, 0.478882723477907, 0.0968404089229942, 0.860925038032819, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.20708914784993, m4 = NULL), c(3.30616426606767, -1.02484718020033, 1.93539730077946, 0.259548998463718, -1.65363018971501, 1.08976583167043, 1.57508385325112, 0.118209116937741, 0.74279350624624), FALSE, 2.23540959240253, 1.29997169988828, c(5.79158790170132, 1.30037635112888, 0.451176470588235, 3.1275183875337, 4.86952426469657, 12.0915406214237, 9.5219321922109, 4.42313424124118, 12.151672436111), 0.304968442837781, 0.136426202998446, 0.0375779984132761, 0.572358887262285, 2.23540959240253, 0.0253904709368229, 2.23540959240253, Common effect model, common, NA, 0.248402616236765, NA, 1, FALSE, FALSE
OR	9	9	0.974	1.339	1.839	.07	.43 [.00, .74]	random	SSW	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, 1.79950836241973, 0.0719383023115588, 0.95, -0.0260037780075166, 0.609268052087494, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162065287495661, 1.79947317248795, 0.0719438639077346, classic, Inf, -0.0260099895956367, 0.609274263675614, 0.136742015566357, , NA, 0.181508983942268, NA, NA, NA, HTS, , NA, 0.136767099100922, 7, 0.95, -0.00025397901047125, 0.646551619697596, 0.181508983942268, 0.181508983942268, 14.0958555018624, 8, 0.0793009381085085, REML, NULL, QP, 6.8605753314767e-06, 0.0706555507589725, 0, 3.09127603601558, 0.0026192699997283, 0, 1.75820250142456, NULL, , , , 1.32739667685768, 1, 1.95348972800686, 0.432457292220184, 0, 0.737953878511125, 4.07674994304655e-05, 0, 0.242348234080177, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 6.8605753314767e-06, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 1.79950836241973, 1.79947317248795, c(40.0621118012422, 19.1566265060241, 27.3, 30.9080646704295, 42.6644892034114, 77.0137785702707, 116.819832402235, 81.4471243042672, 121.047227926078), 0.291632137039989, 0.162062118259813, -0.0260037780075166, 0.609268052087494, 1.79950836241973, 0.0719383023115588, 1.79950836241973, Common effect model, common, NA, 0.181508983942268, NA, 1, FALSE, FALSE
OR	9	9	1.02	1.309	1.68	.03	.36 [.00, .71]	random	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0179999999999723), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.211999999999989), 4.2-0, UM.FS
OR	9	9	1.019	1.309	1.68	.03	.36 [.00, .71]	random (all)	glmer	c(21, 1, 2, 4, 2, 19, 18, 6, 28), c(75, 30, 42, 31, 43, 78, 147, 100, 225), c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 5.00684072552986, 1, 0.0252473416707053, FALSE, c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), c(0, 0, 0.5, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), OR, 0, c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.46149942111032, 0.0554548359151648, 0.212749429577045), c(0.470800315253516, 1.12040889498166, 1.56122714924122, 0.536642983800502, 0.725248915341631, 0.265761390325417, 0.294887554610119, 0.468743451662213, 0.28650093199192), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), c(0.00168015444713672, 0.323778667974397, 0.145731501633408, 0.795362990483667, 0.11681605252122, 0.277397618027478, 0.117582592730875, 0.905825755999269, 0.457736915067221), c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.556324432763862, -3.30149381363506, -0.788714421088967, -0.912621023047227, -2.55885434193782, -0.232216997612435, -0.1164695654146, -0.863265447331764, -0.348782078664277), c(2.40182775637785, 1.09042835060969, 5.33118354730891, 1.19098081856296, 0.284069165854855, 0.809548509425781, 1.03946840763524, 0.974175119162093, 0.774280937818367), FALSE, NULL, 9, 9, 9, 9, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 2.23274178040779, 0.0255659775426849, 0.95, 0.035322010705893, 0.542913683443489, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074689, 0.129490043046692, 2.23274191800552, 0.0255659684635855, classic, Inf, 0.0353220263466307, 0.542913667802747, 0.136737306430947, , NA, 0.181504640177908, NA, NA, NA, HTS, , NA, 0.129490043046692, 7, 0.95, -0.0170774490533134, 0.595313143202691, 0.181504640177908, 0.181504640177908, c(Wald = 12.5268377950632, LRT = 19.5106706502052), c(8, 8), c(0.129199966626729, 0.0123546883139665), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.2513411702581, 1, 1.84466264191184, 0.361371151213215, 0, 0.706122663567014, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(2, 6, 9, 35, 42, 48, 53, 55, 59), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Students", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Design, Arch., Art", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-art, music", "Non-Art Hobbes", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "Drawing hand", "AHQ", "13i_3pt"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n_left_creative = c(21, 1, 2, 4, 2, 19, 18, 6, 28), n_right_creative = c(54, 29, 40, 27, 41, 59, 129, 94, 197), n_control = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), n_left_control = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n_right_control = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), PL_creative = c(28, 3.33333333333333, 4.76190476190476, 12.9032258064516, 4.65116279069767, 24.3589743589744, 12.2448979591837, 6, 12.4444444444444), PL_control = c(8.13953488372093, 9.43396226415094, 0, 11.4181539052005, 13.2040965618142, 19.4385158430471, 8.08435852372583, 5.69476082004556, 10.3053435114504), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.77211127112991, 0.0489021206257103, 0.974358001722383, 0.419088323016755, 0.0853419904948197, 0.796574942631189, 0.89532149083073, 0.433242739236992, 0.708695088055667), effect = c(4.38888888888889, 0.331034482758621, Inf, 1.14933084344849, 0.320654009864198, 1.33464555657352, 1.58645096056623, 1.05702127659574, 1.23707463808987), upper = c(10.8155297724311, 2.31371177621804, Inf, 3.15514004201175, 1.20478785936251, 2.2361722247974, 2.81389813908544, 2.58665434552118, 2.15939645412777), chi_sq = c(9.66, 0.35, 1.43, 0, 2.04, 0.9, 2, 0, 0.36), p = c(0.00188315203416169, 0.555226654080462, 0.231693626958297, 0.999999999999998, 0.153528886490197, 0.34412188746252, 0.15735099029876, 0.999999999999999, 0.548522324881787), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("SR/SL", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "R/L", "SR/SL", "0 split"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(2.30703690798264, 0.577768181828048, Inf, 0.697985202936539, 0.285578173297504, 0.367250952956679, 0.489441812040476, 0.549349789911963, 0.370083679474482), inv_var = c(0.18788448346753, 2.99566163549202, 0, 2.05261533117729, 12.2616799854792, 7.4143679914957, 4.17443655632658, 3.31361520572076, 7.30129899135206), .event.e = c(21, 1, 2, 4, 2, 19, 18, 6, 28), .n.e = c(75, 30, 42, 31, 43, 78, 147, 100, 225), .event.c = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), .n.c = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "peterson_1979", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 2.14485770860516e-08, m4 = NULL), c(3.14162086695801, -0.986722558580527, 1.45477521590232, 0.259352869522669, -1.56827892325176, 1.08618394701055, 1.56500135016035, 0.118305302652264, 0.742578490401021), FALSE, 2.23274178040779, 2.23274191800552, c(NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.289117847074691, 0.129490051026808, 0.035322010705893, 0.542913683443489, 2.23274178040779, 0.0255659775426849, 2.23274178040779, Common effect model, common, NA, 0.181504640177908, NA, 1, FALSE, FALSE, list(b = 0.289117847074691, beta = 0.289117847074691, se = 0.129490051026808, zval = 2.23274178040779, pval = 0.0255659775426849, ci.lb = 0.035322010705893, ci.ub = 0.542913683443489, vb = 0.0167676733149254, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513585797853, QMdf = c(1, NA), QMp = 0.0255659775426849, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292028545, 19.5106706502052, 120.560058405709, 129.463775984671, 151.98862983428), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.02800000000002), list(b = 0.289117847074689, beta = 0.289117847074689, se = 0.129490043046692, zval = 2.23274191800552, pval = 0.0255659684635855, ci.lb = 0.0353220263466307, ci.ub = 0.542913667802747, vb = 0.0167676712482342, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.184277816049851, QE.Wld = 12.5268377950632, QEp.Wld = 0.129199966626729, QE.LRT = 19.5106706502052, QEp.LRT = 0.0123546883139665, QE.df = 8, QM = 4.98513647241896, QMdf = c(1, NA), QMp = 0.0255659684635856, k = 9, k.f = 9, k.yi = 9, k.eff = 18, k.all = 9, p = 1, p.eff = 10, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.47907609457086, -1.10553273151268, 2.27123456310997, 0.139179897757867, -1.13739258804148, 0.288665755906673, 0.461499421110321, 0.0554548359151648, 0.212749429577045), vi.f = c(0.22165293684281, 1.25531609195402, 2.43743021152788, 0.287985692062305, 0.525985989204212, 0.0706291165876984, 0.0869586698639356, 0.219720423476205, 0.0820827840322386), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ti = NA), outdat = list(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), bi = c(54, 29, 40, 27, 41, 59, 129, 94, 197), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), di = c(79, 48, 78, 9232, 4746, 4907, 523, 414, 235), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ni.f = c(161, 83, 120, 10453, 5511, 6169, 716, 539, 487), ids = 1:9, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:9, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-50.2800292029923, 19.5106706504808, 122.560058405985, 132.354147742842, 166.560058405985), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(21, 1, 2, 4, 2, 19, 18, 6, 28), ci = c(7, 5, 0, 1190, 722, 1184, 46, 25, 27), n1i = c(75, 30, 42, 31, 43, 78, 147, 100, 225), n2i = c(86, 53, 78, 10422, 5468, 6091, 569, 439, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.225000000000023), 4.2-0, UM.FS
Music
OR	15	12	1.142	1.334	1.558	<.001	.02 [.00, .55]	random	GLMM	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000387), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.407000000000039), 4.2-0, UM.FS
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	Inverse	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 3.88401281096207, 0.000102746490259109, 0.95, 0.155324355220281, 0.471771773781667, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.88401281096207, 3.82062176216205, c(5.22170527252517, 0.427776590548296, 5.70178701197636, 42.6480889422454, 25.2338741832611, 41.4641170604007, 2.52342857142857, 4.32123201082862, 10.7592756893008, 5.53895856167136, 2.66595210835302, 0.999052244068159, 0.480400900793124, 0.908224711205891, 4.55123826988389), 0.313548064500974, 0.0807278656795439, 0.155324355220281, 0.471771773781667, 3.88401281096207, 0.000102746490259109, 3.88401281096207, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.164	1.366	1.603	<.001	.26 [.00, .60]	random	MH	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 14, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 3.64677076815372, 0.000265556628429634, 0.95, 0.134154570578494, 0.44591301173438, c(5.19983723499271, 0.42762926022759, 5.67572308236278, 41.2318387443267, 24.7312564357051, 40.1241743320202, 2.51831048053284, 4.30624503424782, 10.6668427772898, 5.51435880322254, 2.6602402043258, 0.998249023540028, 0.480215100099573, 0.907560850790552, 4.5346164780102), 0.311976277925169, 0.0816558919846138, 3.82062176216205, 0.000133115666326312, classic, Inf, 0.151933670509833, 0.472018885340505, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.64677076815372, 3.82062176216205, c(2.98701298701299, 0, 6, 32.6529384544192, 20.3611556982343, 31.064561734213, 1.84, 3.2103825136612, 14.4884645982498, 4.92503176620076, 3.63346613545817, 0.228275465183196, 1.58102189781022, 1.93902638911654, 4.35992578849722), 0.290033791156437, 0.079531675993793, 0.134154570578494, 0.44591301173438, 3.64677076815372, 0.000265556628429634, 3.64677076815372, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.048	1.304	1.623	.02	.50 [.10, .73]	random	Peto	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.864512714639274, 3.85922330097087, -0.100526663026663, 0.443694540654044, 0.30902288699383, 0.477240887109883, 0.705673758865248, 0.428817374182758, -0.328157059356651, 0.151412456743484, -0.311277814021056, 3.80987443815582, -1.15406139984312, -0.660637623336967, 0.0562064185176206), c(0.540780565579624, 1.32219331813667, 0.417348609294271, 0.162030993775508, 0.21351520383302, 0.165578835325855, 0.59400074026269, 0.532738598203729, 0.271669860458032, 0.444170488598978, 0.535952736472784, 1.57151003840543, 0.854369065122966, 0.763018377649432, 0.475482940518229), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), c(0.10990091605911, 0.00351376944795559, 0.809656053389246, 0.00617518345023587, 0.147809860882826, 0.00394836566144754, 0.234832826404724, 0.420859973149651, 0.227075768030777, 0.733187785013098, 0.561379701331835, 0.0153362452313665, 0.176767133978651, 0.386588123690052, 0.905901966336454), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.195397717435989, 1.26777201682348, -0.918514906241311, 0.126119628474816, -0.109459222670617, 0.15271233326912, -0.458546298839756, -0.615331091470907, -0.860620201539416, -0.719145703906071, -1.3617258749234, 0.729771361538017, -2.82859399698928, -2.15612616307204, -0.87572302016131), c(1.92442314671454, 6.45067458511826, 0.717461580187986, 0.761269452833273, 0.727504996658277, 0.801769440950646, 1.86989381657025, 1.47296583983642, 0.204306082826113, 1.02197061739304, 0.739170246881287, 6.88997751477362, 0.520471197303052, 0.834850916398102, 0.988135857196551), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 3.64237828972792, 0.00027013070886894, 0.95, 0.140885481768204, 0.469140501187361, c(3.02812775867362, 0.559913985849404, 4.71757530577234, 15.6134167757432, 11.9929702856244, 15.3351211986603, 2.55996515777787, 3.10941550109688, 8.96073806023234, 4.25385545912247, 3.07655604025104, 0.398813571428646, 1.30252439967449, 1.61292798744651, 3.78963775592615), 0.265293388296449, 0.111586324076742, 2.37747224394629, 0.0174317548328194, classic, Inf, 0.0465882119388207, 0.483998564654077, 0.111586324076742, , NA, 0.146574865323034, NA, NA, NA, HTS, , NA, 0.224153841952073, 13, 0.95, -0.218961546082525, 0.749548322675422, 0.146574865323034, 0.146574865323034, 28.2042497518316, 14, 0.013365314539765, REML, NULL, QP, 0.0377934371409155, 0.0558193149766794, 0.0153224119366302, 3.4330894889523, 0.194405342367219, 0.123783730500539, 1.85285981362657, NULL, , , , 1.41936227510385, 1.05509731292569, 1.90938716581667, 0.503620903828834, 0.101713307390774, 0.725708719562553, 0.20234999106332, 0.0267758214048096, 0.37792416072183, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0377934371409155, m4 = NULL), c(1.59863865246834, 2.91880411739605, -0.240869768792693, 2.7383312927697, 1.44731092421644, 2.88225778476268, 1.18800148052538, 0.804930177067383, -1.20792589506757, 0.340888151351694, -0.580793403667718, 2.42433986741923, -1.35077620077105, -0.86582137821128, 0.118209116937741), FALSE, 3.64237828972792, 2.37747224394629, c(3.4194625262421, 0.572018511925952, 5.74119183673469, 38.0893716879198, 21.9352399354322, 36.4745844790012, 2.83417085427136, 3.52347888102288, 13.5493069224456, 5.06874683183781, 3.48134460547232, 0.404916692711883, 1.36996341617971, 1.71763152908857, 4.42313424124118), 0.305012991477783, 0.0837400641053586, 0.140885481768204, 0.469140501187361, 3.64237828972792, 0.00027013070886894, 3.64237828972792, Common effect model, common, NA, 0.146574865323034, NA, 1, FALSE, FALSE
OR	15	12	1.147	1.357	1.606	<.001	.26 [.00, .60]	random	SSW	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 3.58778867043299, 0.000333494416493596, 0.95, 0.138507650203251, 0.472044803600983, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0858781448081737, 3.55476038267959, 0.000378323701918848, classic, Inf, 0.136958156018981, 0.473594297785252, 0.0816558919846138, , NA, 0.0945287956101757, NA, NA, NA, HTS, , NA, 0.0864469630862632, 13, 0.95, 0.12521896842721, 0.498733587423128, 0.0945287956101757, 0.0945287956101757, 18.8617537072242, 14, 0.170299241215162, REML, NULL, QP, 0.000805392731034849, 0.02611255772364, 0, 1.37431897327333, 0.0283794420493929, 0, 1.17231351321791, NULL, , , , 1.16071879537836, 1, 1.58074005968177, 0.257757246897045, 0, 0.599798160008149, 0.00805269762822685, 0, 0.278286561592868, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.000805392731034849, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.58778867043299, 3.55476038267959, c(43.413961038961, 20.6037735849057, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 50, 28.3743169398907, 115.761336515513, 93.9034307496823, 67.5298804780876, 3.99846537502398, 11.9737226277372, 10.9801671857073, 81.4471243042672), 0.305276226902117, 0.0850875720239328, 0.138507650203251, 0.472044803600983, 3.58778867043299, 0.000333494416493596, 3.58778867043299, Common effect model, common, NA, 0.0945287956101757, NA, 1, FALSE, FALSE
OR	15	12	1.129	1.317	1.537	<.001	.02 [.00, .55]	random	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0200000000000387), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.391999999999996), 4.2-0, UM.FS
OR	15	12	1.136	1.324	1.543	<.001	.02 [.00, .55]	random (all)	glmer	c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 13.2803972495, 1, 0.000268195662470572, FALSE, c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), c(0, 0.5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0, 0), NA, c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481695, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), c(0.437616634945504, 1.5289436959849, 0.418788266098715, 0.153126449361913, 0.199071016169349, 0.155297258481462, 0.629512693981669, 0.481056633499186, 0.304865641631271, 0.424899227934642, 0.612454497653423, 1.00047421507267, 1.44277328939782, 1.04930886732219, 0.468743451662213), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), c(0.115930725831071, 0.0446286023763406, 0.809168952003446, 0.00645077335777569, 0.148868816003007, 0.00417125319725485, 0.242527525012138, 0.422686321112159, 0.229221643512792, 0.73322988381643, 0.563073301945487, 0.0405843716584557, 0.354293854097336, 0.401680166585725, 0.905825755999269), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.169742081011596, 0.0736557431593261, -0.921946563243099, 0.116985319571512, -0.102805332404417, 0.140535924960222, -0.498115413036113, -0.557157153396746, -0.964085848422797, -0.687967831412399, -1.55456057129089, 0.0878289736388995, -4.16421414660905, -2.93658350949254, -0.863265447331764), c(1.54568360604601, 6.06700490019927, 0.719673274159816, 0.717229971231204, 0.677538711711014, 0.749289992003167, 1.9695290029936, 1.32855019896823, 0.230965507019175, 0.977606536209147, 0.846216943849666, 4.00961583164571, 1.49135322354318, 1.17663166772748, 0.974175119162093), FALSE, NULL, 15, 15, 15, 15, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 3.63508199958324, 0.000277892231761607, 0.95, 0.132727781142869, 0.443322817972236, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557718, 0.0792348944137266, 3.63508150908598, 0.000277892760489507, classic, Inf, 0.13272776018798, 0.443322838927456, 0.080729250120961, , NA, 0.0937035883374846, NA, NA, NA, HTS, , NA, 0.0792348944137266, 13, 0.95, 0.116848717168164, 0.459201881947272, 0.0937035883374846, 0.0937035883374846, c(Wald = 14.3018794667633, LRT = 26.8096420866894), c(14, 14), c(0.427471536953619, 0.0203801593345872), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.01072390842135, 1, 1.48389162952127, 0.0211076780128692, 0, 0.54585385720005, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(1, 8, 15, 21, 22, 23, 27, 28, 30, 31, 32, 37, 43, 49, 56), study = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Students", "Professionals", "Students", "Professionals", "Professionals", "Professionals", "Professionals", "Students", "Students/Faculty", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Music", "Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Instrumental musicians", "Music theory/composition", "Music students and faculty", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Non-art, music", "Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "Machinists", "Non-music", "Psychology undergrads", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbes"), h = c("Drawing hand", "AHQ", "4i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "0-split", "22i_3pt", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L", "R/L"), n_creative = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n_left_creative = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), n_right_creative = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), n_control = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), n_left_control = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n_right_control = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), PL_creative = c(14.8936170212766, 10.7142857142857, 14.7727272727273, 12.199036918138, 10.8761329305136, 12.5, 8, 19.3548387096774, 10.077519379845, 6.42201834862385, 4, 50, 0, 9.09090909090909, 6), PL_control = c(8.08435852372583, 0, 16.0919540229885, 8.38751625487646, 8.38751625487646, 8.38751625487646, 4, 14.0298507462687, 13.9184397163121, 5.6047197640118, 5.6047197640118, 11.4181539052005, 13.2040965618142, 19.4252873563218, 5.69476082004556), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.861596113076943, 2.29544638516752, 0.402085887574389, 1.12400690794925, 0.903213257329337, 1.15108757063211, 0.641426134697406, 0.588485241665376, 0.384188095080958, 0.512665308627184, 0.224481980153744, 1.36783907390738, 0, 0.0683282371267135, 0.433242739236992), effect = c(1.98967391304348, Inf, 0.903809523809524, 1.5175658631294, 1.33291288923926, 1.56035437430786, 2.08695652173913, 1.47063829787234, 0.693114430046123, 1.15583075335397, 0.701754385964912, 7.75798319327731, 0, 0.414792899408284, 1.05702127659574), upper = c(4.60852887703026, Inf, 2.0315849935859, 2.04892526251243, 1.96704018224163, 2.11513514309315, 6.7563130503474, 3.69357187521327, 1.25169943293002, 2.61109525703796, 2.2025465539857, 44.001011796837, 2.1089364487342, 2.51803875871203, 2.58665434552118), chi_sq = c(1.77, 5.15, 0, 7.06, 1.8, 7.84, 0.8, 0.29, 1.15, 0.01, 0.1, 2.69, 0.85, 0.23, 0), p = c(0.183739843822423, 0.0233028301711607, 0.974242500600563, 0.00786220244261652, 0.179948994875001, 0.00510823102834106, 0.371730267029974, 0.589681160350308, 0.283487582702155, 0.905371649223273, 0.754261701802549, 0.101283373075042, 0.355655057824875, 0.628136158869253, 0.999999999999999), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("R/L", "SR/SL", "(SR+MR)/(SL+ML)", "0-split", "0-split", "0-split", "R/L", "R/L", "0-split", "SR/SL", "SR/SL", "SR/SL", "R/L", "SR/SL", "SR/SL"), pref_success = c("preference", "mix", "pref", "success", "success", "success", "success", "pref", "preference", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.955867759180436, Inf, 0.415696185966884, 0.235952895527371, 0.271389406464512, 0.245935022292584, 1.55994879596856, 0.792128492676504, 0.221307979302652, 0.535323599046442, 0.504617582117497, 10.8760092173159, 0.538003877971539, 0.624937636841371, 0.549349789911963), inv_var = c(1.09447128885182, 0, 5.78692588561539, 17.961780199522, 13.5773251175883, 16.5332884431038, 0.410940848712344, 1.59370791642886, 20.4176546816717, 3.48953229317411, 3.92712968669091, 0.00845397318661848, 3.45484993264602, 2.56051095546973, 3.31361520572076), .event.e = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), .n.e = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), .event.c = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), .n.c = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), .studlab = c("peterson_1979", "preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "quinan_1922", "fry_1990", "oldfield_1969", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 1.18640083617898e-06, m4 = NULL), c(1.57208549122653, 2.00813825240404, -0.241498276644173, 2.72394251378171, 1.44353856821043, 2.86491186536178, 1.16869254903407, 0.801769471465764, -1.20236629073852, 0.340832232391465, -0.578282656226052, 2.04775132809745, -0.926292766405959, -0.838624306233307, 0.118305302652264), FALSE, 3.63508199958324, 3.63508150908598, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.288025299557553, 0.0792348837221759, 0.132727781142869, 0.443322817972236, 3.63508199958324, 0.000277892231761607, 3.63508199958324, Common effect model, common, NA, 0.0937035883374846, NA, 1, FALSE, FALSE, list(b = 0.288025299557553, beta = 0.288025299557553, se = 0.0792348837221759, zval = 3.63508199958324, pval = 0.000277892231761607, ci.lb = 0.132727781142869, ci.ub = 0.443322817972236, vb = 0.00627816679846673, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138211436941, QMdf = c(1, NA), QMp = 0.000277892231761607, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 16, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680059882, 26.8096420866894, 199.573336011976, 221.992494118571, 241.41948985813), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.288025299557718, beta = 0.288025299557718, se = 0.0792348944137266, zval = 3.63508150908598, pval = 0.000277892760489507, ci.lb = 0.13272776018798, ci.ub = 0.443322838927456, vb = 0.00627816849275441, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.112418682342743, QE.Wld = 14.3018794667633, QEp.Wld = 0.427471536953619, QE.LRT = 26.8096420866894, QEp.LRT = 0.0203801593345872, QE.df = 14, QM = 13.2138175776988, QMdf = c(1, NA), QMp = 0.000277892760489507, k = 15, k.f = 15, k.yi = 15, k.eff = 30, k.all = 15, p = 1, p.eff = 16, parms = 17, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.687970762517205, 3.0703303216793, -0.101136644541641, 0.417107645401358, 0.287366689653298, 0.444912958481694, 0.735706794978741, 0.385696522785742, -0.366560170701811, 0.144819352398374, -0.354171813720614, 2.04872240264231, -1.33643046153293, -0.879975920882529, 0.0554548359151648), vi.f = c(0.191508319181027, 2.33766882549198, 0.175383611821968, 0.0234477094941866, 0.0396292694786974, 0.0241172384918579, 0.396286231884058, 0.23141548463357, 0.0929430594472464, 0.180539353899454, 0.375100511695906, 1.00094865502527, 2.08159476459981, 1.10104909904098, 0.219720423476205), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ti = NA), outdat = list(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), bi = c(40, 25, 75, 547, 295, 511, 92, 25, 116, 102, 72, 2, 12, 10, 94), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), di = c(523, 78, 73, 1409, 1409, 1409, 96, 288, 971, 640, 640, 9232, 4746, 4907, 414), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ni.f = c(616, 106, 175, 2161, 1869, 2122, 200, 366, 1257, 787, 753, 10426, 5480, 6101, 539), ids = 1:15, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:15, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-83.7866680062519, 26.8096420872166, 201.573336012504, 225.39369150076, 252.573336012504), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(7, 3, 13, 76, 36, 73, 8, 6, 13, 7, 3, 2, 0, 1, 6), ci = c(46, 0, 14, 129, 129, 129, 4, 47, 157, 38, 38, 1190, 722, 1183, 25), n1i = c(47, 28, 88, 623, 331, 584, 100, 31, 129, 109, 75, 4, 12, 11, 100), n2i = c(569, 78, 87, 1538, 1538, 1538, 100, 335, 1128, 678, 678, 10422, 5468, 6090, 439), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.394000000000005), 4.2-0, UM.FS

Final table

Final table
N	N_stu	study	rl_sm	group1	group2	pL_creative	pL_control	lower	effect	upper	p	I2	comparison	model_type	label	es_type	se
Architecture
10	9							0.934	1.151	1.42	.19	.31 [.00, .67]		random (all)	glmer	OR
		nlsy79	R/L	Architects, except naval	Non-art, architecture, music	0/9 (0%)	722/5468 (13.2%)	0	0	2.812	.50		R/L			OR	0.717
		nlsy97	R/L	Architects, except naval	Non-art, architecture, music	0/4 (0%)	1183/6090 (19.43%)	0	0	3.991	.73		SR/SL			OR	1.018
		wood_1991	R/L	Architecture students (W)	General students (W)	1/27 (3.7%)	22/149 (14.77%)	0.037	0.222	1.37	.21		SR/SL			OR	0.34
		shettel-neuber_1983	R/L	Architecture	Law, Psychology	1/23 (4.35%)	5/53 (9.43%)	0.064	0.436	3.096	.77		SR/SL			OR	0.773
		gotestam_1990	R/L	Architecture (freshmen)	HS seniors	7/60 (11.67%)	14/87 (16.09%)	0.266	0.689	1.788	.61		(SR+MR)/(SL+ML)			OR	0.388
		wood_1991	R/L	Architecture students (M)	General students (M)	9/78 (11.54%)	28/221 (12.67%)	0.41	0.899	1.975	.95		SR/SL			OR	0.399
		cosenza_1993	R/L	Architecture applicants	Non-art/music/ architecture applicants	42/347 (12.1%)	1190/10422 (11.42%)	0.77	1.068	1.482	.76		SR/SL			OR	0.182
		fry_1990	R/L	Architecture	Non-architecture	12/69 (17.39%)	41/297 (13.8%)	0.656	1.315	2.639	.57		R/L			OR	0.506
		peterson_1979	R/L	Design, Arch., Art	Non-art, music	18/147 (12.24%)	46/569 (8.08%)	0.895	1.586	2.814	.16		R/L			OR	0.489
		schacter_1996	R/L	Architects	Non-architects	26/141 (18.44%)	92/1007 (9.14%)	1.4	2.249	3.613	.001		SR/SL			OR	0.565
Art
9	9							1.019	1.309	1.68	.03	.36 [.00, .71]		random (all)	glmer	OR
		nlsy79	R/L	Artistic occupations	Non-art, architecture, music	2/43 (4.65%)	722/5468 (13.2%)	0.085	0.321	1.205	.15		R/L			OR	0.286
		shettel-neuber_1983	R/L	Art	Law, Psychology	1/30 (3.33%)	5/53 (9.43%)	0.049	0.331	2.314	.56		SR/SL			OR	0.578
		giotakos_2004	R/L	Art Hobbies	Non-Art Hobbes	6/100 (6%)	25/439 (5.69%)	0.433	1.057	2.587	1.00		SR/SL			OR	0.549
		cosenza_1993	R/L	Fine Arts applicants	Non-art/music/ architecture applicants	4/31 (12.9%)	1190/10422 (11.42%)	0.419	1.149	3.155	1.00		SR/SL			OR	0.698
		coren_1982	R/L	Science/Visual Art	Lang/Lit	28/225 (12.44%)	27/262 (10.31%)	0.709	1.237	2.159	.55		0 split			OR	0.37
		nlsy97	R/L	Artistic occupations	Non-art, architecture, music	19/78 (24.36%)	1184/6091 (19.44%)	0.797	1.335	2.236	.34		SR/SL			OR	0.367
		peterson_1979	R/L	Design, Arch., Art	Non-art, music	18/147 (12.24%)	46/569 (8.08%)	0.895	1.586	2.814	.16		R/L			OR	0.489
		mebert_1980	R/L	Art	Non-Art	21/75 (28%)	7/86 (8.14%)	1.772	4.389	10.816	.002		SR/SL			OR	2.307
		preti_2007	R/L	Writers, Painters	Noncreatives	2/42 (4.76%)	0/78 (0%)	0.974	Inf	Inf	.23		SR/SL			OR	Inf
Music
15	12							1.136	1.324	1.543	<.001	.02 [.00, .55]		random (all)	glmer	OR
		nlsy79	R/L	Musicians and composers	Non-art, architecture, music	0/12 (0%)	722/5468 (13.2%)	0	0	2.109	.36		R/L			OR	0.538
		nlsy97	R/L	Musicians, singers and related workers	Non-art, architecture, music	1/11 (9.09%)	1183/6090 (19.43%)	0.068	0.415	2.518	.63		SR/SL			OR	0.625
		oldfield_1969	R/L	Music students and faculty	Psychology undergrads	13/129 (10.08%)	157/1128 (13.92%)	0.384	0.693	1.252	.28		0-split			OR	0.221
		byrne_1974	R/L	Instrumental musicians	General students	3/75 (4%)	38/678 (5.6%)	0.224	0.702	2.203	.75		SR/SL			OR	0.505
		gotestam_1990	R/L	Music (freshmen)	HS seniors	13/88 (14.77%)	14/87 (16.09%)	0.402	0.904	2.032	.97		(SR+MR)/(SL+ML)			OR	0.416
		giotakos_2004	R/L	Art Hobbies	Non-Art Hobbes	6/100 (6%)	25/439 (5.69%)	0.433	1.057	2.587	1.00		SR/SL			OR	0.549
		byrne_1974	R/L	Singers	General students	7/109 (6.42%)	38/678 (5.6%)	0.513	1.156	2.611	.91		SR/SL			OR	0.535
		aggleton_1994	R/L	Composers	British adults	36/331 (10.88%)	129/1538 (8.39%)	0.903	1.333	1.967	.18		0-split			OR	0.271
		fry_1990	R/L	Music theory/composition	Non-music	6/31 (19.35%)	47/335 (14.03%)	0.588	1.471	3.694	.59		R/L			OR	0.792
		aggleton_1994	R/L	Instrumental musicians	British adults	76/623 (12.2%)	129/1538 (8.39%)	1.124	1.518	2.049	.008		0-split			OR	0.236
		aggleton_1994	R/L	Choir Members	British adults	73/584 (12.5%)	129/1538 (8.39%)	1.151	1.56	2.115	.005		0-split			OR	0.246
		peterson_1979	R/L	Music	Non-art, music	7/47 (14.89%)	46/569 (8.08%)	0.862	1.99	4.609	.18		R/L			OR	0.956
		quinan_1922	R/L	Instrumental musicians	Machinists	8/100 (8%)	4/100 (4%)	0.641	2.087	6.756	.37		R/L			OR	1.56
		cosenza_1993	R/L	Music applicants	Non-art/music/ architecture applicants	2/4 (50%)	1190/10422 (11.42%)	1.368	7.758	44.001	.10		SR/SL			OR	10.876
		preti_2007	R/L	Musicians	Noncreatives	3/28 (10.71%)	0/78 (0%)	2.295	Inf	Inf	.02		SR/SL			OR	Inf

Blank (collapse)

S/M

Strong/mixed comparisons only — an odds ratio greater than one is a mixedy advantage.

From raw proportions, using metabin

All studies

From raw proportions, using metabin
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	7	7	0.81	0.964	1.148	.68	.00 [.00, .71]	random	GLMM	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0320000000000391), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.336000000000013), 4.2-0, UM.FS
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	Inverse	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, 0.95, -0.195927686278407, 0.149671606287923, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.26232765169782, -0.26232765169782, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.195927686278407, 0.149671606287923, -0.26232765169782, 0.7930688453099, -0.26232765169782, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	MH	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), 7, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.407693294766147, 0.683498860814005, 0.95, -0.209646375660956, 0.137447225576158, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.407693294766147, -0.26232765169782, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.209646375660956, 0.137447225576158, -0.407693294766147, 0.683498860814005, -0.407693294766147, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.811	0.965	1.147	.68	.00 [.00, .71]	random	Peto	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-1.43684210526316, 0.212037275367835, -0.245902766320189, 2.71520154460688, -0.0375389837855228, -1.02389642850852, -1.11687158278867), c(1.56089219338149, 0.447210581153716, 0.400819752502115, 1.39946633835025, 0.0929909160392439, 2.27870185976276, 1.63695215942607), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), c(0.357297866196262, 0.635405097974775, 0.539546033178936, 0.052359125243574, 0.686444799637499, 0.653191301938128, 0.495057335302806), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -0.664479357198675, -1.03149504551659, -0.0277020761357525, -0.219797830111829, -5.49007000514796, -4.32523885967883), c(1.62245037751428, 1.08855390793435, 0.539689512876215, 5.45810516534952, 0.144719862540783, 3.44227714813093, 2.09149569410149), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.408575845067285, 0.682850960082584, 0.95, -0.209062236981563, 0.136935284266936, c(0.410443756449928, 4.9999931809195, 6.22434624554858, 0.510592496367057, 115.603203253772, 0.192586011146259, 0.373187891805021), -0.0360629821707267, 0.0882800114978071, -0.408506767940583, 0.682901662789817, classic, Inf, -0.20908862526121, 0.136962660919757, 0.0882800114978071, , NA, 0.0873647685198526, NA, NA, NA, HTS, , NA, 0.0882968249587724, 5, 0.95, -0.263037196554106, 0.190911232212653, 0.0873647685198526, 0.0873647685198526, 5.87625206637751, 6, 0.437194360691289, REML, NULL, QP, 2.9688677471406e-06, 0.0824090604727355, 0, 7.22275526342338, 0.00172304026277409, 0, 2.68751842103889, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 5.44211919471491e-05, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.9688677471406e-06, m4 = NULL), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), FALSE, -0.408575845067285, -0.408506767940583, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.209062236981563, 0.136935284266936, -0.408575845067285, 0.682850960082584, -0.408575845067285, Common effect model, common, NA, 0.0873647685198526, NA, 1, FALSE, FALSE
OR	7	7	0.837	1.046	1.307	.69	.00 [.00, .71]	random	SSW	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, 0.95, -0.177378289936688, 0.268112979119369, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, classic, Inf, -0.177378289936688, 0.268112979119369, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, 0.39919238669549, 0.39919238669549, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, -0.177378289936688, 0.268112979119369, 0.39919238669549, 0.689751452535042, 0.39919238669549, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
Art
OR	8	8	1.306	1.928	2.845	<.001	.71 [.40, .86]	random	GLMM	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0319999999999254), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.437999999999988), 4.2-0, UM.FS
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	Inverse	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Inverse, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 5.29672404520868, 1.17898659523565e-07, 0.95, 0.372347043518412, 0.809769442358692, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.29672404520868, 2.56084885476388, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 0.372347043518412, 0.809769442358692, 5.29672404520868, 1.17898659523565e-07, 5.29672404520868, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	MH	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), MH, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 5.87874623167465, 4.13385540515412e-09, 0.95, 0.418365342813119, 0.836853001775561, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.87874623167465, 2.56084885476388, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 0.418365342813119, 0.836853001775561, 5.87874623167465, 4.13385540515412e-09, 5.87874623167465, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.199	1.933	3.116	.007	.71 [.41, .86]	random	Peto	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Peto, Peto, 0, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.737734224795348, -0.12052903696899, 1.886625, 0.190703412437214, 0.0609904207495266, 0.117134174635773, 0.371336934921835, 1.50046978291384), c(0.342493017102583, 1.21687522422527, 0.673934343983151, 0.294238027642615, 1.04464964727608, 0.372381982228678, 0.17013786477182, 0.233931487850484), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), c(0.0312391951359797, 0.921100172165413, 0.00511945666092442, 0.51690324668251, 0.953443067420015, 0.753100447472451, 0.0290678656470361, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0664602463178242, -2.50556065012963, 0.565737957848396, -0.385992524624412, -1.98648526437405, -0.61272109902407, 0.0378728475625207, 1.04197249187702), c(1.40900820327287, 2.26450257619165, 3.2075120421516, 0.767399349498841, 2.10846610587311, 0.846989448295615, 0.704801022281149, 1.95896707395066), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 5.86396181097839, 4.51951467668089e-09, 0.95, 0.426214879742889, 0.854168916148306, c(2.56799826388559, 0.57048573535209, 1.37685214872971, 2.78797780291132, 0.733460583896562, 2.43442133368832, 3.32166554888682, 3.05968680490349), 0.659207927166043, 0.243594349900081, 2.70617084278204, 0.00680640200487933, classic, Inf, 0.181771774524437, 1.13664407980765, 0.243594349900081, , NA, 0.234144502384702, NA, NA, NA, HTS, , NA, 0.57571269179161, 6, 0.95, -0.749510281233418, 2.06792613556551, 0.234144502384702, 0.234144502384702, 24.5275098344813, 7, 0.000919864214315797, REML, NULL, QP, 0.272106896186699, 0.236777542936739, 0.038761825825206, 1.77860140203637, 0.521638664390111, 0.196880232184966, 1.33364215666586, NULL, , , , 1.8718787290726, 1.30390385731621, 2.68726099450806, 0.714606168859455, 0.411821886871513, 0.861522152839296, 0.573211823699272, 0.278633686271807, 0.867789961126736, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.272106896186699, m4 = NULL), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), FALSE, 5.86396181097839, 2.70617084278204, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 0.426214879742889, 0.854168916148306, 5.86396181097839, 4.51951467668089e-09, 5.86396181097839, Common effect model, common, NA, 0.234144502384702, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.982	3.367	.01	.71 [.40, .86]	random	SSW	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), SSW, SSW, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 4.72688278677217, 2.27992782863981e-06, 0.95, 0.400373538518923, 0.967587665096766, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.27050562547953, 2.52852634985073, 0.0114542488124973, classic, Inf, 0.153799318252485, 1.2141618853632, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 4.72688278677217, 2.52852634985073, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 0.400373538518923, 0.967587665096766, 4.72688278677217, 2.27992782863981e-06, 4.72688278677217, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
Music
OR	11	8	1.24	1.413	1.609	<.001	.10 [.00, .50]	random	GLMM	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0320000000000391), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.379999999999995), 4.2-0, UM.FS
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	Inverse	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, 0.95, 0.226707962816201, 0.488123152611205, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.35945612940463, 5.35945612940463, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 0.226707962816201, 0.488123152611205, 5.35945612940463, 8.34728604234335e-08, 5.35945612940463, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	MH	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 11, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 5.18766442364861, 2.12947884198379e-07, 0.95, 0.214634084356199, 0.475299584844259, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.18766442364861, 5.35945612940463, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 0.214634084356199, 0.475299584844259, 5.18766442364861, 2.12947884198379e-07, 5.18766442364861, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.182	1.406	1.673	<.001	.34 [.00, .68]	random	Peto	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.17826257861635, -0.301878909223286, 0.490670728524915, 0.452618839163683, 0.441543762495517, -0.172032692354803, 0.516686677945751, 1.10546580074985, -1.02444480232342, -1.11800549988975, 0.371336934921835), c(1.13845897443781, 0.355932285189848, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.22726902886927, 0.244167347549023, 0.663625553755456, 1.97448261801463, 0.988187320844407, 0.17013786477182), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), c(0.300686329135404, 0.396362352687967, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.449076125152964, 0.0343348569588449, 0.0957537505474681, 0.603870823550084, 0.257899388302445, 0.0290678656470361), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-1.05307600915816, -0.999493369130427, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.617471803739965, 0.0381274705489931, -0.195216383831291, -4.89435962173246, -3.05481705872391, 0.0378728475625207), c(3.40960116639086, 0.395735550683856, 0.771661460016443, 0.820306387820303, 0.731535599651959, 0.273406419030359, 0.995245885342509, 2.406147985331, 2.84547001708561, 0.818806058944414, 0.704801022281149), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 5.20883577784693, 1.90029208094365e-07, 0.95, 0.226555516539067, 0.499906194045163, c(0.760520908389271, 6.87345705765463, 25.4110227662677, 18.5209740001616, 24.5755209358123, 14.1943399067026, 12.7523207953466, 2.17770850151917, 0.255272590644762, 1.00470847959426, 20.9440320370434), 0.341026864449578, 0.0885719517845025, 3.85028056375345, 0.000117982595131526, classic, Inf, 0.167429028911534, 0.514624699987621, 0.0885719517845025, , NA, 0.098861981477167, NA, NA, NA, HTS, , NA, 0.163231111784296, 9, 0.95, -0.0282275642647816, 0.710281293163937, 0.098861981477167, 0.098861981477167, 15.2376327952008, 10, 0.123635383699418, REML, NULL, QP, 0.018799405211421, 0.0316117385422144, 0, 0.778484511672533, 0.13711092302009, 0, 0.882317693165298, NULL, , , , 1.23440806847658, 1, 1.76110216026958, 0.343730083642025, 0, 0.677573372724364, 0.217850717125471, 0, 0.57232693717241, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.018799405211421, m4 = NULL), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), FALSE, 5.20883577784693, 3.85028056375345, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 0.226555516539067, 0.499906194045163, 5.20883577784693, 1.90029208094365e-07, 5.20883577784693, Common effect model, common, NA, 0.098861981477167, NA, 1, FALSE, FALSE
OR	11	8	1.259	1.443	1.656	<.001	.17 [.00, .57]	random	SSW	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, 0.95, 0.229942155875115, 0.504183860507076, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, classic, Inf, 0.229942155875115, 0.504183860507076, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.24668760411165, 5.24668760411165, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 0.229942155875115, 0.504183860507076, 5.24668760411165, 1.54858150940595e-07, 5.24668760411165, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE

Excluding Cosenza 1993

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	6	6	0.562	0.977	1.699	.94	.00 [.00, .75]	random	GLMM	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0.5, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.0808919362821185, 0.935527892865106, 0.95, -0.575636489903183, 0.530004311964672, c(NA, NA, NA, NA, NA, NA), -0.0228160889692557, 0.282056379082751, -0.0808919445234807, 0.935527886310929, classic, Inf, -0.575636433581224, 0.530004255642713, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.282056379082751, 4, 0.95, -0.805930142063373, 0.760297964124862, 0.238681935329344, 0.238681935329344, c(Wald = 3.47368710567779, LRT = 5.99059709151523), c(5, 5), c(0.627372791614464, 0.307134937951713), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, -0.0808919362821185, -0.0808919445234807, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.575636489903183, 0.530004311964672, -0.0808919362821185, 0.935527892865106, -0.0808919362821185, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE, list(b = -0.0228160889692555, beta = -0.0228160889692555, se = 0.282056407818972, zval = -0.0808919362821185, pval = 0.935527892865106, ci.lb = -0.575636489903183, ci.ub = 0.530004311964672, vb = 0.0795558171917425, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350535547031, QMdf = c(1, NA), QMp = 0.935527892865106, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 7, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.271162118965, 5.99059709151523, 60.5423242379299, 63.9366707864459, 88.5423242379299), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0380000000000109), list(b = -0.0228160889692557, beta = -0.0228160889692557, se = 0.282056379082751, zval = -0.0808919445234807, pval = 0.935527886310929, ci.lb = -0.575636433581224, ci.ub = 0.530004255642713, vb = 0.0795558009812725, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350668878989, QMdf = c(1, NA), QMp = 0.935527886310929, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.2711621190967, 5.9905970917788, 62.5423242381935, 66.4215774364975, 110.542324238193), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.189999999999941), 4.2-0, UM.FS
OR	6	6	0.654	1.099	1.845	.72	.00 [.00, .75]	random	Inverse	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0.5, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 0.473093094834541, 0.449644515802929), 0.0939552218795918, 0.264632101606543, 0.355040908904109, 0.722558944175892, 0.95, -0.424714166422377, 0.612624610181561, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 0.473093094834541, 0.449644515802929), 0.0939552218795918, 0.264632101606543, 0.355040908904109, 0.722558944175892, classic, Inf, -0.424714166422377, 0.612624610181561, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.264632101606543, 4, 0.95, -0.640781281304101, 0.828691725063284, 0.238681935329344, 0.238681935329344, 4.06746714827754, 5, 0.539743832556414, REML, NULL, QP, 0, 0.225962158397211, 0, 3.51067437618813, 0, 0, 1.87367936856553, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, 0.355040908904109, 0.355040908904109, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 0.473093094834541, 0.449644515802929), 0.0939552218795918, 0.264632101606543, -0.424714166422377, 0.612624610181561, 0.355040908904109, 0.722558944175892, 0.355040908904109, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE
OR	6	6	0.654	1.099	1.845	.72	.00 [.00, .75]	random	MH	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0), 6, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 0.197188241738178, 0.416803413193305), -0.0217723294513836, 0.275505510056763, -0.0790268385082309, 0.937011275774364, 0.95, -0.561753206704977, 0.518208547802209, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 0.473093094834541, 0.449644515802929), 0.0939552218795918, 0.264632101606543, 0.355040908904109, 0.722558944175892, classic, Inf, -0.424714166422377, 0.612624610181561, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.264632101606543, 4, 0.95, -0.640781281304101, 0.828691725063284, 0.238681935329344, 0.238681935329344, 4.06746714827754, 5, 0.539743832556414, REML, NULL, QP, 0, 0.225962158397211, 0, 3.51067437618813, 0, 0, 1.87367936856553, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, -0.0790268385082309, 0.355040908904109, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 0.197188241738178, 0.416803413193305), -0.0217723294513836, 0.275505510056763, -0.561753206704977, 0.518208547802209, -0.0790268385082309, 0.937011275774364, -0.0790268385082309, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE
OR	6	6	0.564	0.978	1.694	.94	.15 [.00, .78]	random	Peto	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-1.43684210526316, 0.212037275367835, -0.245902766320189, 2.71520154460688, -1.02389642850852, -1.11687158278867), c(1.56089219338149, 0.447210581153716, 0.400819752502115, 1.39946633835025, 2.27870185976276, 1.63695215942607), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.449333213172134, -0.682287247282936), c(0.357297866196262, 0.635405097974775, 0.539546033178936, 0.052359125243574, 0.653191301938128, 0.495057335302806), c(NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -0.664479357198675, -1.03149504551659, -0.0277020761357525, -5.49007000514796, -4.32523885967883), c(1.62245037751428, 1.08855390793435, 0.539689512876215, 5.45810516534952, 3.44227714813093, 2.09149569410149), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 0.192586121259762, 0.373188305277323), -0.0226398766880901, 0.280481564792506, -0.0807178778571012, 0.935666318735207, 0.95, -0.572373642008839, 0.527093888632659, c(0.410444037431339, 5.00003487865119, 6.22441086480855, 0.510592931196768, 0.192586073007639, 0.373188124092256), -0.0226396211297643, 0.280482488422071, -0.0807167009146614, 0.935667254745253, classic, Inf, -0.572375196731196, 0.527095954471667, 0.280482488422071, , NA, 0.304002190870852, NA, NA, NA, HTS, , NA, 0.280484807573025, 4, 0.95, -0.801390292198234, 0.756111049938706, 0.304002190870852, 0.304002190870852, 5.87370980271265, 5, 0.31870214390277, REML, NULL, QP, 1.30096783971029e-06, 0.248742833274644, 0, 11.8319773222538, 0.00114059977192278, 0, 3.43976413759052, NULL, , , , 1.08385513817232, 1, 2.15161759488972, 0.148749228691746, 0, 0.783992004965641, 2.75615607352475e-06, 0, 0.744107322996755, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 1.30096783971029e-06, m4 = NULL), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.449333213172134, -0.682287247282936), FALSE, -0.0807178778571012, -0.0807167009146614, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 0.192586121259762, 0.373188305277323), -0.0226398766880901, 0.280481564792506, -0.572373642008839, 0.527093888632659, -0.0807178778571012, 0.935666318735207, -0.0807178778571012, Common effect model, common, NA, 0.304002190870852, NA, 1, FALSE, FALSE
OR	6	6	0.692	1.271	2.337	.44	.00 [.00, .75]	random	SSW	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0.5, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 8.98521088186964, 3.99737446668855), 0.240192995512405, 0.310472811125696, 0.773636166856371, 0.43914597812354, 0.95, -0.368322532472865, 0.848708523497676, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 8.98521088186964, 3.99737446668855), 0.240192995512405, 0.310472811125696, 0.773636166856371, 0.43914597812354, classic, Inf, -0.368322532472865, 0.848708523497676, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.264632101606543, 4, 0.95, -0.640781281304101, 0.828691725063284, 0.238681935329344, 0.238681935329344, 4.06746714827754, 5, 0.539743832556414, REML, NULL, QP, 0, 0.225962158397211, 0, 3.51067437618813, 0, 0, 1.87367936856553, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, 0.773636166856371, 0.773636166856371, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 8.98521088186964, 3.99737446668855), 0.240192995512405, 0.310472811125696, -0.368322532472865, 0.848708523497676, 0.773636166856371, 0.43914597812354, 0.773636166856371, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE
Art
OR	7	7	1.362	2.123	3.308	<.001	.72 [.41, .87]	random	GLMM	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 6.01549203782723, 1.79341118217618e-09, 0.95, 0.460512900944519, 0.905628155189022, c(NA, NA, NA, NA, NA, NA, NA), 0.752689999803856, 0.226382510222019, 3.32485932356556, 0.000884631586224699, classic, Inf, 0.308988433038929, 1.19639156656878, 0.264292130605014, , NA, 0.274332510602625, NA, NA, NA, HTS, , NA, 0.47374048551596, 5, 0.95, -0.465098687068998, 1.97047868667671, 0.274332510602625, 0.274332510602625, c(Wald = 21.8171791239098, LRT = 24.2806823594805), c(6, 6), c(0.00130677877589285, 0.000463668978485186), ML, NULL, , 0.173181006682475, NA, NA, NA, 0.416150221293315, NA, NA, NULL, , , , 1.90688135987838, 1.2980007253093, 2.80138250291437, 0.724987361293445, 0.406459812286104, 0.872574843264364, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.252880476381233, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 6.01549203782723, 3.32485932356556, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 0.460512900944519, 0.905628155189022, 6.01549203782723, 1.79341118217618e-09, 6.01549203782723, Common effect model, common, NA, 0.274332510602625, NA, 1, FALSE, FALSE, list(b = 0.68307052806677, beta = 0.68307052806677, se = 0.113551896298992, zval = 6.01549203782723, pval = 1.79341118217618e-09, ci.lb = 0.460512900944519, ci.ub = 0.905628155189022, vb = 0.012894033153097, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 36.1861444571628, QMdf = c(1, NA), QMp = 1.79341118217617e-09, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.1152872097944, 24.2806823594805, 104.230574419589, 109.343033056511, 133.030574419589), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0180000000000291), list(b = 0.752689999803856, beta = 0.752689999803856, se = 0.226382510222019, zval = 3.32485932356556, pval = 0.000884631586224699, ci.lb = 0.308988433038929, ci.ub = 1.19639156656878, vb = 0.0512490409344225, tau2 = 0.173181006682475, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.481235285643, H2 = 2.29785934082384, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 11.0546895215009, QMdf = c(1, NA), QMp = 0.0008846315862247, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-33.9137911730747, 3.87769028604107, 85.8275823461494, 91.5790983126867, 130.827582346149 ), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.25), 4.2-0, UM.FS
OR	7	7	1.199	2.121	3.751	.010	.72 [.41, .87]	random	Inverse	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), Inverse, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.663041279834332, 0.12109804741272, 5.47524335858687, 4.36910751234244e-08, 0.95, 0.425693468307277, 0.900389091361386, c(2.16534972311996, 0.530032087225641, 1.00390820616607, 0.731632290100436, 2.16526853058814, 2.75811937349542, 2.4561068707422), 0.751732156381, 0.29098284286642, 2.58342433174349, 0.00978249233179301, classic, Inf, 0.18141626424374, 1.32204804851826, 0.29098284286642, , NA, 0.278703435274481, NA, NA, NA, HTS, , NA, 0.647416393567622, 5, 0.95, -0.9125046650171, 2.4159689777791, 0.278703435274481, 0.278703435274481, 21.8171781276524, 6, 0.00130677931827906, REML, NULL, QP, 0.334476971817482, 0.320245006094685, 0.0408272561946399, 2.72906583606076, 0.578339841112025, 0.2020575566383, 1.65198844913055, NULL, , , , 1.90688131634056, 1.29800069043959, 2.80138245024912, 0.724987348735295, 0.40645978039618, 0.872574838473245, 0.564330363042972, 0.252528867751075, 0.87613185833487, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.334476971817482, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.47524335858687, 2.58342433174349, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.663041279834332, 0.12109804741272, 0.425693468307277, 0.900389091361386, 5.47524335858687, 4.36910751234244e-08, 5.47524335858687, Common effect model, common, NA, 0.278703435274481, NA, 1, FALSE, FALSE
OR	7	7	1.199	2.121	3.751	.010	.72 [.41, .87]	random	MH	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), MH, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), 7, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.700723827581814, 0.115570720164266, 6.06316051838945, 1.33472335338788e-09, 0.95, 0.474209378392495, 0.927238276771132, c(2.16534972311996, 0.530032087225641, 1.00390820616607, 0.731632290100436, 2.16526853058814, 2.75811937349542, 2.4561068707422), 0.751732156381, 0.29098284286642, 2.58342433174349, 0.00978249233179301, classic, Inf, 0.18141626424374, 1.32204804851826, 0.29098284286642, , NA, 0.278703435274481, NA, NA, NA, HTS, , NA, 0.647416393567622, 5, 0.95, -0.9125046650171, 2.4159689777791, 0.278703435274481, 0.278703435274481, 21.8171781276524, 6, 0.00130677931827906, REML, NULL, QP, 0.334476971817482, 0.320245006094685, 0.0408272561946399, 2.72906583606076, 0.578339841112025, 0.2020575566383, 1.65198844913055, NULL, , , , 1.90688131634056, 1.29800069043959, 2.80138245024912, 0.724987348735295, 0.40645978039618, 0.872574838473245, 0.564330363042972, 0.252528867751075, 0.87613185833487, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.334476971817482, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 6.06316051838945, 2.58342433174349, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.700723827581814, 0.115570720164266, 0.474209378392495, 0.927238276771132, 6.06316051838945, 1.33472335338788e-09, 6.06316051838945, Common effect model, common, NA, 0.278703435274481, NA, 1, FALSE, FALSE
OR	7	7	1.24	2.12	3.626	.006	.73 [.41, .87]	random	Peto	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), Peto, Peto, 0, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.737734224795348, -0.12052903696899, 1.886625, 0.0609904207495266, 0.117134174635773, 0.371336934921835, 1.50046978291384), c(0.342493017102583, 1.21687522422527, 0.673934343983151, 1.04464964727608, 0.372381982228678, 0.17013786477182, 0.233931487850484), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), c(0.0312391951359797, 0.921100172165413, 0.00511945666092442, 0.953443067420015, 0.753100447472451, 0.0290678656470361, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0664602463178242, -2.50556065012963, 0.565737957848396, -1.98648526437405, -0.61272109902407, 0.0378728475625207, 1.04197249187702), c(1.40900820327287, 2.26450257619165, 3.2075120421516, 2.10846610587311, 0.846989448295615, 0.704801022281149, 1.95896707395066), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.71195244503927, 0.117566174202213, 6.05575923406947, 1.3975690556318e-09, 0.95, 0.481526977802771, 0.942377912275768, c(2.43347496970783, 0.563564804079098, 1.33721836604022, 0.722060029554819, 2.31319847352473, 3.10000224843432, 2.87061457612131), 0.751384577487954, 0.273791469450474, 2.74436810977368, 0.00606275111077406, classic, Inf, 0.214763158090727, 1.28800599688518, 0.273791469450474, , NA, 0.261789678764705, NA, NA, NA, HTS, , NA, 0.607120487965942, 5, 0.95, -0.809268320919952, 2.31203747589586, 0.261789678764705, 0.261789678764705, 21.8212703169274, 6, 0.00130455329321287, REML, NULL, QP, 0.293633518164154, 0.283159255189909, 0.0345031659685983, 2.36846106433598, 0.541879615933423, 0.185750278515534, 1.5389805276013, NULL, , , , 1.90706014224894, 1.2981439147477, 2.80159876330922, 0.725038922443226, 0.406590743838332, 0.872594514854374, 0.559587188975762, 0.254661387995502, 0.864512989956022, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.293633518164154, m4 = NULL), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), FALSE, 6.05575923406947, 2.74436810977368, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.71195244503927, 0.117566174202213, 0.481526977802771, 0.942377912275768, 6.05575923406947, 1.3975690556318e-09, 6.05575923406947, Common effect model, common, NA, 0.261789678764705, NA, 1, FALSE, FALSE
OR	7	7	1.154	2.087	3.775	.01	.72 [.41, .87]	random	SSW	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), SSW, SSW, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.735886220601496, 0.156950367075925, 4.68865561968077, 2.7500574124742e-06, 0.95, 0.428269153772342, 1.04350328743065, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.735886220601496, 0.302351395951877, 2.43387737068236, 0.0149380549848834, classic, Inf, 0.143288373860408, 1.32848406734258, 0.29098284286642, , NA, 0.278703435274481, NA, NA, NA, HTS, , NA, 0.647416393567622, 5, 0.95, -0.9125046650171, 2.4159689777791, 0.278703435274481, 0.278703435274481, 21.8171781276524, 6, 0.00130677931827906, REML, NULL, QP, 0.334476971817482, 0.320245006094685, 0.0408272561946399, 2.72906583606076, 0.578339841112025, 0.2020575566383, 1.65198844913055, NULL, , , , 1.90688131634056, 1.29800069043959, 2.80138245024912, 0.724987348735295, 0.40645978039618, 0.872574838473245, 0.564330363042972, 0.252528867751075, 0.87613185833487, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.334476971817482, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 4.68865561968077, 2.43387737068236, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.735886220601496, 0.156950367075925, 0.428269153772342, 1.04350328743065, 4.68865561968077, 2.7500574124742e-06, 4.68865561968077, Common effect model, common, NA, 0.278703435274481, NA, 1, FALSE, FALSE
Music
OR	10	7	1.23	1.402	1.599	<.001	.11 [.00, .51]	random	GLMM	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 5.04886105521582, 4.44451832588345e-07, 0.95, 0.206732411261298, 0.469083710924787, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.33790806112192, 0.0669275824317245, 5.04886100535057, 4.44451948583072e-07, classic, Inf, 0.206732409983404, 0.469083712260436, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0669275824317245, 8, 0.95, 0.183572779275146, 0.492243342968695, 0.0739889744407337, 0.0739889744407337, c(Wald = 10.0806489215946, LRT = 14.5752245007061), c(9, 9), c(0.343995786023132, 0.103284307984992), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05833458905934, 1, 1.43255780482523, 0.107200333034084, 0, 0.512723250121622, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.04886105521582, 5.04886100535057, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 0.206732411261298, 0.469083710924787, 5.04886105521582, 4.44451832588345e-07, 5.04886105521582, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE, list(b = 0.337908061093042, beta = 0.337908061093042, se = 0.0669275817649923, zval = 5.04886105521582, pval = 4.44451832588345e-07, ci.lb = 0.206732411261298, ci.ub = 0.469083710924787, vb = 0.00447930120090973, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.490997954875, QMdf = c(1, NA), QMp = 4.44451832588346e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515825181, 14.5752245007061, 140.397103165036, 151.35015817413, 173.397103165036), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0219999999999345), list(b = 0.33790806112192, beta = 0.33790806112192, se = 0.0669275824317245, zval = 5.04886100535057, pval = 4.44451948583072e-07, ci.lb = 0.206732409983404, ci.ub = 0.469083712260436, vb = 0.00447930129015528, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.4909974513496, QMdf = c(1, NA), QMp = 4.44451948583072e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515827691, 14.5752245012081, 142.397103165538, 154.345890448186, 186.968531736967), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.256999999999948), 4.2-0, UM.FS
OR	10	7	1.245	1.419	1.619	<.001	.18 [.00, .59]	random	Inverse	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.350167639753323, 0.0670473193615991, 5.22269410749745, 1.76338554394109e-07, 0.95, 0.218757308544634, 0.481577970962013, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.350167639753323, 0.0670473193615991, 5.22269410749745, 1.76338554394109e-07, classic, Inf, 0.218757308544634, 0.481577970962013, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0670473193615991, 8, 0.95, 0.195556244051122, 0.504779035455525, 0.0739889744407337, 0.0739889744407337, 10.960079059846, 9, 0.278455249632961, REML, NULL, QP, 0, 0.0171619920495334, 0, 0.329692612017147, 0, 0, 0.574188655423587, NULL, , , , 1.10353367062592, 1, 1.55903666653453, 0.178838040231579, 0, 0.588578160813064, 0, 0, 0.520434746030939, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.22269410749745, 5.22269410749745, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.350167639753323, 0.0670473193615991, 0.218757308544634, 0.481577970962013, 5.22269410749745, 1.76338554394109e-07, 5.22269410749745, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE
OR	10	7	1.245	1.419	1.619	<.001	.18 [.00, .59]	random	MH	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 10, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.337318347702761, 0.0669043242559294, 5.0418018783422, 4.61168623061539e-07, 0.95, 0.206188281751149, 0.468448413654372, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.350167639753323, 0.0670473193615991, 5.22269410749745, 1.76338554394109e-07, classic, Inf, 0.218757308544634, 0.481577970962013, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0670473193615991, 8, 0.95, 0.195556244051122, 0.504779035455525, 0.0739889744407337, 0.0739889744407337, 10.960079059846, 9, 0.278455249632961, REML, NULL, QP, 0, 0.0171619920495334, 0, 0.329692612017147, 0, 0, 0.574188655423587, NULL, , , , 1.10353367062592, 1, 1.55903666653453, 0.178838040231579, 0, 0.588578160813064, 0, 0, 0.520434746030939, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.0418018783422, 5.22269410749745, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.337318347702761, 0.0669043242559294, 0.206188281751149, 0.468448413654372, 5.0418018783422, 4.61168623061539e-07, 5.0418018783422, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE
OR	10	7	1.156	1.384	1.657	<.001	.36 [.00, .69]	random	Peto	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.17826257861635, -0.301878909223286, 0.490670728524915, 0.452618839163683, 0.441543762495517, -0.172032692354803, 0.516686677945751, -1.02444480232342, -1.11800549988975, 0.371336934921835), c(1.13845897443781, 0.355932285189848, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.22726902886927, 0.244167347549023, 1.97448261801463, 0.988187320844407, 0.17013786477182), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, -0.518842147799465, -1.13137001083399, 2.18256491827878), c(0.300686329135404, 0.396362352687967, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.449076125152964, 0.0343348569588449, 0.603870823550084, 0.257899388302445, 0.0290678656470361), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-1.05307600915816, -0.999493369130427, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.617471803739965, 0.0381274705489931, -4.89435962173246, -3.05481705872391, 0.0378728475625207), c(3.40960116639086, 0.395735550683856, 0.771661460016443, 0.820306387820303, 0.731535599651959, 0.273406419030359, 0.995245885342509, 2.84547001708561, 0.818806058944414, 0.704801022281149), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.354943778282713, 0.0701218054053422, 5.06181745080499, 4.15278558743269e-07, 0.95, 0.217507565157316, 0.49237999140811, c(0.758799162508813, 6.73533424052724, 23.6202607106926, 17.551134077781, 22.8966917115899, 13.6176422676127, 12.2849167172834, 0.255078319283184, 1.00170578404294, 19.712266879389), 0.324636000457522, 0.0918887012378061, 3.53292620403209, 0.000410987175520176, classic, Inf, 0.144537455445261, 0.504734545469783, 0.0918887012378061, , NA, 0.100903684152868, NA, NA, NA, HTS, , NA, 0.173857622895634, 8, 0.95, -0.0762803968765776, 0.725552397791621, 0.100903684152868, 0.100903684152868, 13.9727256774084, 9, 0.12329874159696, REML, NULL, QP, 0.0217829396237498, 0.0336106931265094, 0, 0.741844851774097, 0.147590445570673, 0, 0.861304157527465, NULL, , , , 1.24600364175535, 1, 1.80493472345851, 0.355888020148316, 0, 0.693043382877177, 0.257983696548315, 0, 0.65838457069954, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.0217829396237498, m4 = NULL), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, -0.518842147799465, -1.13137001083399, 2.18256491827878), FALSE, 5.06181745080499, 3.53292620403209, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.354943778282713, 0.0701218054053422, 0.217507565157316, 0.49237999140811, 5.06181745080499, 4.15278558743269e-07, 5.06181745080499, Common effect model, common, NA, 0.100903684152868, NA, 1, FALSE, FALSE
OR	10	7	1.252	1.437	1.65	<.001	.18 [.00, .59]	random	SSW	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.362885373142229, 0.0702841931141431, 5.1631150200856, 2.42873797259636e-07, 0.95, 0.225130885956051, 0.500639860328408, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.362885373142229, 0.0702841931141431, 5.1631150200856, 2.42873797259636e-07, classic, Inf, 0.225130885956051, 0.500639860328408, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0670473193615991, 8, 0.95, 0.195556244051122, 0.504779035455525, 0.0739889744407337, 0.0739889744407337, 10.960079059846, 9, 0.278455249632961, REML, NULL, QP, 0, 0.0171619920495334, 0, 0.329692612017147, 0, 0, 0.574188655423587, NULL, , , , 1.10353367062592, 1, 1.55903666653453, 0.178838040231579, 0, 0.588578160813064, 0, 0, 0.520434746030939, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.1631150200856, 5.1631150200856, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.362885373142229, 0.0702841931141431, 0.225130885956051, 0.500639860328408, 5.1631150200856, 2.42873797259636e-07, 5.1631150200856, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE

Excluding Peterson 1977 and Peterson 1983

Make sure that this exclusion does not change results too much.

From raw proportions, using metabin, excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	7	7	0.81	0.964	1.148	.68	.00 [.00, .71]	random	GLMM	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.196000000000026), 4.2-0, UM.FS
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	Inverse	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, 0.95, -0.195927686278407, 0.149671606287923, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.26232765169782, -0.26232765169782, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.195927686278407, 0.149671606287923, -0.26232765169782, 0.7930688453099, -0.26232765169782, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	MH	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), 7, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.407693294766147, 0.683498860814005, 0.95, -0.209646375660956, 0.137447225576158, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.407693294766147, -0.26232765169782, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.209646375660956, 0.137447225576158, -0.407693294766147, 0.683498860814005, -0.407693294766147, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.811	0.965	1.147	.68	.00 [.00, .71]	random	Peto	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-1.43684210526316, 0.212037275367835, -0.245902766320189, 2.71520154460688, -0.0375389837855228, -1.02389642850852, -1.11687158278867), c(1.56089219338149, 0.447210581153716, 0.400819752502115, 1.39946633835025, 0.0929909160392439, 2.27870185976276, 1.63695215942607), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), c(0.357297866196262, 0.635405097974775, 0.539546033178936, 0.052359125243574, 0.686444799637499, 0.653191301938128, 0.495057335302806), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -0.664479357198675, -1.03149504551659, -0.0277020761357525, -0.219797830111829, -5.49007000514796, -4.32523885967883), c(1.62245037751428, 1.08855390793435, 0.539689512876215, 5.45810516534952, 0.144719862540783, 3.44227714813093, 2.09149569410149), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.408575845067285, 0.682850960082584, 0.95, -0.209062236981563, 0.136935284266936, c(0.410443756449928, 4.9999931809195, 6.22434624554858, 0.510592496367057, 115.603203253772, 0.192586011146259, 0.373187891805021), -0.0360629821707267, 0.0882800114978071, -0.408506767940583, 0.682901662789817, classic, Inf, -0.20908862526121, 0.136962660919757, 0.0882800114978071, , NA, 0.0873647685198526, NA, NA, NA, HTS, , NA, 0.0882968249587724, 5, 0.95, -0.263037196554106, 0.190911232212653, 0.0873647685198526, 0.0873647685198526, 5.87625206637751, 6, 0.437194360691289, REML, NULL, QP, 2.9688677471406e-06, 0.0824090604727355, 0, 7.22275526342338, 0.00172304026277409, 0, 2.68751842103889, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 5.44211919471491e-05, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.9688677471406e-06, m4 = NULL), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), FALSE, -0.408575845067285, -0.408506767940583, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.209062236981563, 0.136935284266936, -0.408575845067285, 0.682850960082584, -0.408575845067285, Common effect model, common, NA, 0.0873647685198526, NA, 1, FALSE, FALSE
OR	7	7	0.837	1.046	1.307	.69	.00 [.00, .71]	random	SSW	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, 0.95, -0.177378289936688, 0.268112979119369, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, classic, Inf, -0.177378289936688, 0.268112979119369, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, 0.39919238669549, 0.39919238669549, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, -0.177378289936688, 0.268112979119369, 0.39919238669549, 0.689751452535042, 0.39919238669549, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
Art
OR	8	8	1.306	1.928	2.845	<.001	.71 [.40, .86]	random	GLMM	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.273000000000025), 4.2-0, UM.FS
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	Inverse	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Inverse, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 5.29672404520868, 1.17898659523565e-07, 0.95, 0.372347043518412, 0.809769442358692, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.29672404520868, 2.56084885476388, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 0.372347043518412, 0.809769442358692, 5.29672404520868, 1.17898659523565e-07, 5.29672404520868, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	MH	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), MH, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 5.87874623167465, 4.13385540515412e-09, 0.95, 0.418365342813119, 0.836853001775561, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.87874623167465, 2.56084885476388, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 0.418365342813119, 0.836853001775561, 5.87874623167465, 4.13385540515412e-09, 5.87874623167465, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.199	1.933	3.116	.007	.71 [.41, .86]	random	Peto	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Peto, Peto, 0, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.737734224795348, -0.12052903696899, 1.886625, 0.190703412437214, 0.0609904207495266, 0.117134174635773, 0.371336934921835, 1.50046978291384), c(0.342493017102583, 1.21687522422527, 0.673934343983151, 0.294238027642615, 1.04464964727608, 0.372381982228678, 0.17013786477182, 0.233931487850484), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), c(0.0312391951359797, 0.921100172165413, 0.00511945666092442, 0.51690324668251, 0.953443067420015, 0.753100447472451, 0.0290678656470361, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0664602463178242, -2.50556065012963, 0.565737957848396, -0.385992524624412, -1.98648526437405, -0.61272109902407, 0.0378728475625207, 1.04197249187702), c(1.40900820327287, 2.26450257619165, 3.2075120421516, 0.767399349498841, 2.10846610587311, 0.846989448295615, 0.704801022281149, 1.95896707395066), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 5.86396181097839, 4.51951467668089e-09, 0.95, 0.426214879742889, 0.854168916148306, c(2.56799826388559, 0.57048573535209, 1.37685214872971, 2.78797780291132, 0.733460583896562, 2.43442133368832, 3.32166554888682, 3.05968680490349), 0.659207927166043, 0.243594349900081, 2.70617084278204, 0.00680640200487933, classic, Inf, 0.181771774524437, 1.13664407980765, 0.243594349900081, , NA, 0.234144502384702, NA, NA, NA, HTS, , NA, 0.57571269179161, 6, 0.95, -0.749510281233418, 2.06792613556551, 0.234144502384702, 0.234144502384702, 24.5275098344813, 7, 0.000919864214315797, REML, NULL, QP, 0.272106896186699, 0.236777542936739, 0.038761825825206, 1.77860140203637, 0.521638664390111, 0.196880232184966, 1.33364215666586, NULL, , , , 1.8718787290726, 1.30390385731621, 2.68726099450806, 0.714606168859455, 0.411821886871513, 0.861522152839296, 0.573211823699272, 0.278633686271807, 0.867789961126736, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.272106896186699, m4 = NULL), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), FALSE, 5.86396181097839, 2.70617084278204, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 0.426214879742889, 0.854168916148306, 5.86396181097839, 4.51951467668089e-09, 5.86396181097839, Common effect model, common, NA, 0.234144502384702, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.982	3.367	.01	.71 [.40, .86]	random	SSW	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), SSW, SSW, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 4.72688278677217, 2.27992782863981e-06, 0.95, 0.400373538518923, 0.967587665096766, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.27050562547953, 2.52852634985073, 0.0114542488124973, classic, Inf, 0.153799318252485, 1.2141618853632, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 4.72688278677217, 2.52852634985073, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 0.400373538518923, 0.967587665096766, 4.72688278677217, 2.27992782863981e-06, 4.72688278677217, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
Music
OR	11	8	1.24	1.413	1.609	<.001	.10 [.00, .50]	random	GLMM	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0189999999998918), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.307000000000016), 4.2-0, UM.FS
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	Inverse	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, 0.95, 0.226707962816201, 0.488123152611205, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.35945612940463, 5.35945612940463, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 0.226707962816201, 0.488123152611205, 5.35945612940463, 8.34728604234335e-08, 5.35945612940463, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	MH	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 11, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 5.18766442364861, 2.12947884198379e-07, 0.95, 0.214634084356199, 0.475299584844259, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.18766442364861, 5.35945612940463, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 0.214634084356199, 0.475299584844259, 5.18766442364861, 2.12947884198379e-07, 5.18766442364861, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.182	1.406	1.673	<.001	.34 [.00, .68]	random	Peto	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.17826257861635, -0.301878909223286, 0.490670728524915, 0.452618839163683, 0.441543762495517, -0.172032692354803, 0.516686677945751, 1.10546580074985, -1.02444480232342, -1.11800549988975, 0.371336934921835), c(1.13845897443781, 0.355932285189848, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.22726902886927, 0.244167347549023, 0.663625553755456, 1.97448261801463, 0.988187320844407, 0.17013786477182), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), c(0.300686329135404, 0.396362352687967, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.449076125152964, 0.0343348569588449, 0.0957537505474681, 0.603870823550084, 0.257899388302445, 0.0290678656470361), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-1.05307600915816, -0.999493369130427, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.617471803739965, 0.0381274705489931, -0.195216383831291, -4.89435962173246, -3.05481705872391, 0.0378728475625207), c(3.40960116639086, 0.395735550683856, 0.771661460016443, 0.820306387820303, 0.731535599651959, 0.273406419030359, 0.995245885342509, 2.406147985331, 2.84547001708561, 0.818806058944414, 0.704801022281149), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 5.20883577784693, 1.90029208094365e-07, 0.95, 0.226555516539067, 0.499906194045163, c(0.760520908389271, 6.87345705765463, 25.4110227662677, 18.5209740001616, 24.5755209358123, 14.1943399067026, 12.7523207953466, 2.17770850151917, 0.255272590644762, 1.00470847959426, 20.9440320370434), 0.341026864449578, 0.0885719517845025, 3.85028056375345, 0.000117982595131526, classic, Inf, 0.167429028911534, 0.514624699987621, 0.0885719517845025, , NA, 0.098861981477167, NA, NA, NA, HTS, , NA, 0.163231111784296, 9, 0.95, -0.0282275642647816, 0.710281293163937, 0.098861981477167, 0.098861981477167, 15.2376327952008, 10, 0.123635383699418, REML, NULL, QP, 0.018799405211421, 0.0316117385422144, 0, 0.778484511672533, 0.13711092302009, 0, 0.882317693165298, NULL, , , , 1.23440806847658, 1, 1.76110216026958, 0.343730083642025, 0, 0.677573372724364, 0.217850717125471, 0, 0.57232693717241, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.018799405211421, m4 = NULL), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), FALSE, 5.20883577784693, 3.85028056375345, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 0.226555516539067, 0.499906194045163, 5.20883577784693, 1.90029208094365e-07, 5.20883577784693, Common effect model, common, NA, 0.098861981477167, NA, 1, FALSE, FALSE
OR	11	8	1.259	1.443	1.656	<.001	.17 [.00, .57]	random	SSW	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, 0.95, 0.229942155875115, 0.504183860507076, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, classic, Inf, 0.229942155875115, 0.504183860507076, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.24668760411165, 5.24668760411165, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 0.229942155875115, 0.504183860507076, 5.24668760411165, 1.54858150940595e-07, 5.24668760411165, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE

From raw proportions, using glmer()

With glmer, any number of variables can be modeled as random effects.

The model type “random” treats only each estimate as a random effect.

The model type “random (all) includes study, estimate, handedness comparison, and population (Students/Faculty/Professionals) as random effects. Because estimates might vary along all of these variables, I think it makes sense to use this model for the published analysis.

All studies

From raw proportions, with all random effects, using glmer()
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.185000000000059), 4.2-0, UM.FS
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random (all)	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0220000000000482), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.205000000000041), 4.2-0, UM.FS
Art
OR	8	8	1.506	1.846	2.262	<.001	.71 [.40, .86]	random	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.270999999999958), 4.2-0, UM.FS
OR	8	8	1.498	1.836	2.25	<.001	.71 [.40, .86]	random (all)	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.265999999999963), 4.2-0, UM.FS
Music
OR	11	8	1.243	1.416	1.612	<.001	.10 [.00, .50]	random	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.285000000000082), 4.2-0, UM.FS
OR	11	8	1.246	1.417	1.612	<.001	.10 [.00, .50]	random (all)	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.338000000000079), 4.2-0, UM.FS

Excluding Cosenza 1993

From raw proportions, with all random effects, using glmer(), excluding Cosenza 1993
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	6	6	0.585	1	1.709	1.00	.00 [.00, .75]	random	glmer	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0.5, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.0808919362821185, 0.935527892865106, 0.95, -0.575636489903183, 0.530004311964672, c(NA, NA, NA, NA, NA, NA), -0.0228160889692557, 0.282056379082751, -0.0808919445234807, 0.935527886310929, classic, Inf, -0.575636433581224, 0.530004255642713, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.282056379082751, 4, 0.95, -0.805930142063373, 0.760297964124862, 0.238681935329344, 0.238681935329344, c(Wald = 3.47368710567779, LRT = 5.99059709151523), c(5, 5), c(0.627372791614464, 0.307134937951713), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, -0.0808919362821185, -0.0808919445234807, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.575636489903183, 0.530004311964672, -0.0808919362821185, 0.935527892865106, -0.0808919362821185, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE, list(b = -0.0228160889692555, beta = -0.0228160889692555, se = 0.282056407818972, zval = -0.0808919362821185, pval = 0.935527892865106, ci.lb = -0.575636489903183, ci.ub = 0.530004311964672, vb = 0.0795558171917425, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350535547031, QMdf = c(1, NA), QMp = 0.935527892865106, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 7, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.271162118965, 5.99059709151523, 60.5423242379299, 63.9366707864459, 88.5423242379299), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = -0.0228160889692557, beta = -0.0228160889692557, se = 0.282056379082751, zval = -0.0808919445234807, pval = 0.935527886310929, ci.lb = -0.575636433581224, ci.ub = 0.530004255642713, vb = 0.0795558009812725, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350668878989, QMdf = c(1, NA), QMp = 0.935527886310929, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.2711621190967, 5.9905970917788, 62.5423242381935, 66.4215774364975, 110.542324238193), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.149999999999977), 4.2-0, UM.FS
OR	6	6	0.586	1	1.706	1.00	.00 [.00, .75]	random (all)	glmer	c(0, 7, 45, 2, 0, 0), c(23, 148, 60, 27, 9, 4), c(2, 41, 69, 2, 120, 635), c(55, 1048, 87, 149, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.00654357741960089, 1, 0.935527538621616, FALSE, c(0.5, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 3.6980228830214, 2.87563940794759), FALSE, NULL, 6, 6, 6, 6, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.0808919362821185, 0.935527892865106, 0.95, -0.575636489903183, 0.530004311964672, c(NA, NA, NA, NA, NA, NA), -0.0228160889692557, 0.282056379082751, -0.0808919445234807, 0.935527886310929, classic, Inf, -0.575636433581224, 0.530004255642713, 0.264632101606543, , NA, 0.238681935329344, NA, NA, NA, HTS, , NA, 0.282056379082751, 4, 0.95, -0.805930142063373, 0.760297964124862, 0.238681935329344, 0.238681935329344, c(Wald = 3.47368710567779, LRT = 5.99059709151523), c(5, 5), c(0.627372791614464, 0.307134937951713), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.98515236871779, 0, 0, 0.746246344420476, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 9, 4), n_left_creative = c(0, 7, 45, 2, 0, 0), n_right_creative = c(23, 141, 15, 25, 9, 4), n_control = c(55, 1048, 87, 149, 5468, 6090), n_left_control = c(2, 41, 69, 2, 120, 635), n_right_control = c(53, 1007, 18, 147, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 0, 0), .n.e = c(23, 148, 60, 27, 9, 4), .event.c = c(2, 41, 69, 2, 120, 635), .n.c = c(55, 1048, 87, 149, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, 0.583601357792218, -0.0316885125547638), FALSE, -0.0808919362821185, -0.0808919445234807, c(NA, NA, NA, NA, NA, NA), -0.0228160889692555, 0.282056407818972, -0.575636489903183, 0.530004311964672, -0.0808919362821185, 0.935527892865106, -0.0808919362821185, Common effect model, common, NA, 0.238681935329344, NA, 1, FALSE, FALSE, list(b = -0.0228160889692555, beta = -0.0228160889692555, se = 0.282056407818972, zval = -0.0808919362821185, pval = 0.935527892865106, ci.lb = -0.575636489903183, ci.ub = 0.530004311964672, vb = 0.0795558171917425, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350535547031, QMdf = c(1, NA), QMp = 0.935527892865106, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 7, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.271162118965, 5.99059709151523, 60.5423242379299, 63.9366707864459, 88.5423242379299), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0240000000000009), list(b = -0.0228160889692557, beta = -0.0228160889692557, se = 0.282056379082751, zval = -0.0808919445234807, pval = 0.935527886310929, ci.lb = -0.575636433581224, ci.ub = 0.530004255642713, vb = 0.0795558009812725, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.548006915080775, QE.Wld = 3.47368710567779, QEp.Wld = 0.627372791614464, QE.LRT = 5.99059709151523, QEp.LRT = 0.307134937951713, QE.df = 5, QM = 0.00654350668878989, QMdf = c(1, NA), QMp = 0.935527886310929, k = 6, k.f = 6, k.yi = 6, k.eff = 12, k.all = 6, p = 1, p.eff = 7, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 0, 0), bi = c(23, 141, 15, 25, 9, 4), ci = c(2, 41, 69, 2, 120, 635), di = c(53, 1007, 18, 147, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 5477, 6094), ni.f = c(78, 1196, 147, 176, 5477, 6094), ids = 1:6, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:6, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-23.2711621190967, 5.9905970917788, 62.5423242381935, 66.4215774364975, 110.542324238193), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 0, 0), ci = c(2, 41, 69, 2, 120, 635), n1i = c(23, 148, 60, 27, 9, 4), n2i = c(55, 1048, 87, 149, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.152999999999906), 4.2-0, UM.FS
Art
OR	7	7	1.593	1.988	2.481	<.001	.72 [.41, .87]	random	glmer	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 6.01549203782723, 1.79341118217618e-09, 0.95, 0.460512900944519, 0.905628155189022, c(NA, NA, NA, NA, NA, NA, NA), 0.752689999803856, 0.226382510222019, 3.32485932356556, 0.000884631586224699, classic, Inf, 0.308988433038929, 1.19639156656878, 0.264292130605014, , NA, 0.274332510602625, NA, NA, NA, HTS, , NA, 0.47374048551596, 5, 0.95, -0.465098687068998, 1.97047868667671, 0.274332510602625, 0.274332510602625, c(Wald = 21.8171791239098, LRT = 24.2806823594805), c(6, 6), c(0.00130677877589285, 0.000463668978485186), ML, NULL, , 0.173181006682475, NA, NA, NA, 0.416150221293315, NA, NA, NULL, , , , 1.90688135987838, 1.2980007253093, 2.80138250291437, 0.724987361293445, 0.406459812286104, 0.872574843264364, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.252880476381233, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 6.01549203782723, 3.32485932356556, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 0.460512900944519, 0.905628155189022, 6.01549203782723, 1.79341118217618e-09, 6.01549203782723, Common effect model, common, NA, 0.274332510602625, NA, 1, FALSE, FALSE, list(b = 0.68307052806677, beta = 0.68307052806677, se = 0.113551896298992, zval = 6.01549203782723, pval = 1.79341118217618e-09, ci.lb = 0.460512900944519, ci.ub = 0.905628155189022, vb = 0.012894033153097, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 36.1861444571628, QMdf = c(1, NA), QMp = 1.79341118217617e-09, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.1152872097944, 24.2806823594805, 104.230574419589, 109.343033056511, 133.030574419589), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0160000000000764), list(b = 0.752689999803856, beta = 0.752689999803856, se = 0.226382510222019, zval = 3.32485932356556, pval = 0.000884631586224699, ci.lb = 0.308988433038929, ci.ub = 1.19639156656878, vb = 0.0512490409344225, tau2 = 0.173181006682475, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.481235285643, H2 = 2.29785934082384, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 11.0546895215009, QMdf = c(1, NA), QMp = 0.0008846315862247, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-33.9137911730747, 3.87769028604107, 85.8275823461494, 91.5790983126867, 130.827582346149 ), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.233999999999924), 4.2-0, UM.FS
OR	7	7	1.59	1.983	2.474	<.001	.72 [.41, .87]	random (all)	glmer	c(28, 1, 8, 1, 9, 84, 69), c(103, 31, 50, 43, 78, 184, 225), c(15, 2, 2, 120, 636, 256, 21), c(101, 55, 80, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 36.745731117302, 1, 1.3458499953907e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 6.01549203782723, 1.79341118217618e-09, 0.95, 0.460512900944519, 0.905628155189022, c(NA, NA, NA, NA, NA, NA, NA), 0.752689999803856, 0.226382510222019, 3.32485932356556, 0.000884631586224699, classic, Inf, 0.308988433038929, 1.19639156656878, 0.264292130605014, , NA, 0.274332510602625, NA, NA, NA, HTS, , NA, 0.47374048551596, 5, 0.95, -0.465098687068998, 1.97047868667671, 0.274332510602625, 0.274332510602625, c(Wald = 21.8171791239098, LRT = 24.2806823594805), c(6, 6), c(0.00130677877589285, 0.000463668978485186), ML, NULL, , 0.173181006682475, NA, NA, NA, 0.416150221293315, NA, NA, NULL, , , , 1.90688135987838, 1.2980007253093, 2.80138250291437, 0.724987361293445, 0.406459812286104, 0.872574843264364, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 42, 69, 100, 156), n_control = c(101, 55, 80, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577), .event.e = c(28, 1, 8, 1, 9, 84, 69), .n.e = c(103, 31, 50, 43, 78, 184, 225), .event.c = c(15, 2, 2, 120, 636, 256, 21), .n.c = c(101, 55, 80, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.252880476381233, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 6.01549203782723, 3.32485932356556, c(NA, NA, NA, NA, NA, NA, NA), 0.68307052806677, 0.113551896298992, 0.460512900944519, 0.905628155189022, 6.01549203782723, 1.79341118217618e-09, 6.01549203782723, Common effect model, common, NA, 0.274332510602625, NA, 1, FALSE, FALSE, list(b = 0.68307052806677, beta = 0.68307052806677, se = 0.113551896298992, zval = 6.01549203782723, pval = 1.79341118217618e-09, ci.lb = 0.460512900944519, ci.ub = 0.905628155189022, vb = 0.012894033153097, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 36.1861444571628, QMdf = c(1, NA), QMp = 1.79341118217617e-09, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-44.1152872097944, 24.2806823594805, 104.230574419589, 109.343033056511, 133.030574419589), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0159999999999627), list(b = 0.752689999803856, beta = 0.752689999803856, se = 0.226382510222019, zval = 3.32485932356556, pval = 0.000884631586224699, ci.lb = 0.308988433038929, ci.ub = 1.19639156656878, vb = 0.0512490409344225, tau2 = 0.173181006682475, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.481235285643, H2 = 2.29785934082384, vt = 0.133435882637748, QE.Wld = 21.8171791239098, QEp.Wld = 0.00130677877589285, QE.LRT = 24.2806823594805, QEp.LRT = 0.000463668978485186, QE.df = 6, QM = 11.0546895215009, QMdf = c(1, NA), QMp = 0.0008846315862247, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 1, 9, 84, 69), bi = c(75, 30, 42, 42, 69, 100, 156), ci = c(15, 2, 2, 120, 636, 256, 21), di = c(86, 53, 78, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 5511, 6169, 879, 487), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-33.9137911730747, 3.87769028604107, 85.8275823461494, 91.5790983126867, 130.827582346149 ), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 1, 9, 84, 69), ci = c(15, 2, 2, 120, 636, 256, 21), n1i = c(103, 31, 50, 43, 78, 184, 225), n2i = c(101, 55, 80, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.34699999999998), 4.2-0, UM.FS
Music
OR	10	7	1.233	1.406	1.602	<.001	.11 [.00, .51]	random	glmer	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 5.04886105521582, 4.44451832588345e-07, 0.95, 0.206732411261298, 0.469083710924787, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.33790806112192, 0.0669275824317245, 5.04886100535057, 4.44451948583072e-07, classic, Inf, 0.206732409983404, 0.469083712260436, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0669275824317245, 8, 0.95, 0.183572779275146, 0.492243342968695, 0.0739889744407337, 0.0739889744407337, c(Wald = 10.0806489215946, LRT = 14.5752245007061), c(9, 9), c(0.343995786023132, 0.103284307984992), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05833458905934, 1, 1.43255780482523, 0.107200333034084, 0, 0.512723250121622, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.04886105521582, 5.04886100535057, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 0.206732411261298, 0.469083710924787, 5.04886105521582, 4.44451832588345e-07, 5.04886105521582, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE, list(b = 0.337908061093042, beta = 0.337908061093042, se = 0.0669275817649923, zval = 5.04886105521582, pval = 4.44451832588345e-07, ci.lb = 0.206732411261298, ci.ub = 0.469083710924787, vb = 0.00447930120090973, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.490997954875, QMdf = c(1, NA), QMp = 4.44451832588346e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515825181, 14.5752245007061, 140.397103165036, 151.35015817413, 173.397103165036), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0230000000000246), list(b = 0.33790806112192, beta = 0.33790806112192, se = 0.0669275824317245, zval = 5.04886100535057, pval = 4.44451948583072e-07, ci.lb = 0.206732409983404, ci.ub = 0.469083712260436, vb = 0.00447930129015528, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.4909974513496, QMdf = c(1, NA), QMp = 4.44451948583072e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515827691, 14.5752245012081, 142.397103165538, 154.345890448186, 186.968531736967), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.250999999999976), 4.2-0, UM.FS
OR	10	7	1.234	1.406	1.602	<.001	.11 [.00, .51]	random (all)	glmer	c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 25.6456444156854, 1, 4.10220351657673e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 10, 10, 10, 10, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 5.04886105521582, 4.44451832588345e-07, 0.95, 0.206732411261298, 0.469083710924787, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.33790806112192, 0.0669275824317245, 5.04886100535057, 4.44451948583072e-07, classic, Inf, 0.206732409983404, 0.469083712260436, 0.0670473193615991, , NA, 0.0739889744407337, NA, NA, NA, HTS, , NA, 0.0669275824317245, 8, 0.95, 0.183572779275146, 0.492243342968695, 0.0739889744407337, 0.0739889744407337, c(Wald = 10.0806489215946, LRT = 14.5752245007061), c(9, 9), c(0.343995786023132, 0.103284307984992), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05833458905934, 1, 1.43255780482523, 0.107200333034084, 0, 0.512723250121622, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies"), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.0745486566836351, 1.70184173708771, 16.5840533845998), .event.e = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.04886105521582, 5.04886100535057, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.337908061093042, 0.0669275817649923, 0.206732411261298, 0.469083710924787, 5.04886105521582, 4.44451832588345e-07, 5.04886105521582, Common effect model, common, NA, 0.0739889744407337, NA, 1, FALSE, FALSE, list(b = 0.337908061093042, beta = 0.337908061093042, se = 0.0669275817649923, zval = 5.04886105521582, pval = 4.44451832588345e-07, ci.lb = 0.206732411261298, ci.ub = 0.469083710924787, vb = 0.00447930120090973, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.490997954875, QMdf = c(1, NA), QMp = 4.44451832588346e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 11, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515825181, 14.5752245007061, 140.397103165036, 151.35015817413, 173.397103165036), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.33790806112192, beta = 0.33790806112192, se = 0.0669275824317245, zval = 5.04886100535057, pval = 4.44451948583072e-07, ci.lb = 0.206732409983404, ci.ub = 0.469083712260436, vb = 0.00447930129015528, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0491744644186674, QE.Wld = 10.0806489215946, QEp.Wld = 0.343995786023132, QE.LRT = 14.5752245007061, QEp.LRT = 0.103284307984992, QE.df = 9, QM = 25.4909974513496, QMdf = c(1, NA), QMp = 4.44451948583072e-07, k = 10, k.f = 10, k.yi = 10, k.eff = 20, k.all = 10, p = 1, p.eff = 11, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 5480, 6101, 879), ids = 1:10, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:10, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-59.1985515827691, 14.5752245012081, 142.397103165538, 154.345890448186, 186.968531736967), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.293000000000006), 4.2-0, UM.FS

Excluding Peterson 1977 and Peterson 1983

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0230000000000246), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.16700000000003), 4.2-0, UM.FS
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random (all)	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.174000000000092), 4.2-0, UM.FS
Art
OR	8	8	1.506	1.846	2.262	<.001	.71 [.40, .86]	random	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0369999999999209), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.281000000000063), 4.2-0, UM.FS
OR	8	8	1.498	1.836	2.25	<.001	.71 [.40, .86]	random (all)	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0170000000000528), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.269000000000005), 4.2-0, UM.FS
Music
OR	11	8	1.243	1.416	1.612	<.001	.10 [.00, .50]	random	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.295000000000073), 4.2-0, UM.FS
OR	11	8	1.246	1.417	1.612	<.001	.10 [.00, .50]	random (all)	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0220000000000482), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.313999999999965), 4.2-0, UM.FS

All methods

All studies, including Cosenza 1993, Peterson 1979, and Peterson 1983.

From raw proportions, with all random effects, using glmer(), excluding Peterson 1977 and 1983
es_type	N	N_stu	lower	effect	upper	p	I2	model_type	label	metagen_obj
Architecture
OR	7	7	0.81	0.964	1.148	.68	.00 [.00, .71]	random	GLMM	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0320000000000391), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.336000000000013), 4.2-0, UM.FS
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	Inverse	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, 0.95, -0.195927686278407, 0.149671606287923, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.26232765169782, -0.26232765169782, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.195927686278407, 0.149671606287923, -0.26232765169782, 0.7930688453099, -0.26232765169782, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.822	0.977	1.161	.79	.00 [.00, .71]	random	MH	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), 7, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.407693294766147, 0.683498860814005, 0.95, -0.209646375660956, 0.137447225576158, c(0.406298474663909, 5.70344480193571, 6.29179331306991, 0.955289836236028, 114.370641304911, 0.473093094834541, 0.449644515802929), -0.0231280399952422, 0.088164704885491, -0.26232765169782, 0.7930688453099, classic, Inf, -0.195927686278407, 0.149671606287923, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.407693294766147, -0.26232765169782, c(0.58974358974359, 4.83361204013378, 7.04081632653061, 0.284090909090909, 117.192002903636, 0.197188241738178, 0.416803413193305), -0.036099575042399, 0.0885459130818076, -0.209646375660956, 0.137447225576158, -0.407693294766147, 0.683498860814005, -0.407693294766147, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.811	0.965	1.147	.68	.00 [.00, .71]	random	Peto	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-1.43684210526316, 0.212037275367835, -0.245902766320189, 2.71520154460688, -0.0375389837855228, -1.02389642850852, -1.11687158278867), c(1.56089219338149, 0.447210581153716, 0.400819752502115, 1.39946633835025, 0.0929909160392439, 2.27870185976276, 1.63695215942607), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), c(0.357297866196262, 0.635405097974775, 0.539546033178936, 0.052359125243574, 0.686444799637499, 0.653191301938128, 0.495057335302806), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-4.4961345880406, -0.664479357198675, -1.03149504551659, -0.0277020761357525, -0.219797830111829, -5.49007000514796, -4.32523885967883), c(1.62245037751428, 1.08855390793435, 0.539689512876215, 5.45810516534952, 0.144719862540783, 3.44227714813093, 2.09149569410149), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.408575845067285, 0.682850960082584, 0.95, -0.209062236981563, 0.136935284266936, c(0.410443756449928, 4.9999931809195, 6.22434624554858, 0.510592496367057, 115.603203253772, 0.192586011146259, 0.373187891805021), -0.0360629821707267, 0.0882800114978071, -0.408506767940583, 0.682901662789817, classic, Inf, -0.20908862526121, 0.136962660919757, 0.0882800114978071, , NA, 0.0873647685198526, NA, NA, NA, HTS, , NA, 0.0882968249587724, 5, 0.95, -0.263037196554106, 0.190911232212653, 0.0873647685198526, 0.0873647685198526, 5.87625206637751, 6, 0.437194360691289, REML, NULL, QP, 2.9688677471406e-06, 0.0824090604727355, 0, 7.22275526342338, 0.00172304026277409, 0, 2.68751842103889, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 5.44211919471491e-05, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 2.9688677471406e-06, m4 = NULL), c(-0.920526165327543, 0.474132957276683, -0.613499621176707, 1.94016924180376, -0.403684417622906, -0.449333213172134, -0.682287247282936), FALSE, -0.408575845067285, -0.408506767940583, c(0.410444256598103, 5.00006740351252, 6.2244612689918, 0.510593270365998, 115.642893123005, 0.192586121259762, 0.373188305277323), -0.0360634763573133, 0.0882662957017791, -0.209062236981563, 0.136935284266936, -0.408575845067285, 0.682850960082584, -0.408575845067285, Common effect model, common, NA, 0.0873647685198526, NA, 1, FALSE, FALSE
OR	7	7	0.837	1.046	1.307	.69	.00 [.00, .71]	random	SSW	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, 0.95, -0.177378289936688, 0.268112979119369, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, 0.39919238669549, 0.689751452535042, classic, Inf, -0.177378289936688, 0.268112979119369, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.088164704885491, 5, 0.95, -0.249762628918122, 0.203506548927637, 0.0745296759722754, 0.0745296759722754, 4.28765862397823, 6, 0.637810757095989, REML, NULL, QP, 0, 0.0761725484182551, 0, 2.06684882062989, 0, 0, 1.43765392936892, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, 0, 0, 1, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, 0.39919238669549, 0.39919238669549, c(16.2179487179487, 129.685618729097, 35.5102040816327, 22.8579545454545, 509.26320246809, 8.98521088186964, 3.99737446668855), 0.0453673445913403, 0.113647820207421, -0.177378289936688, 0.268112979119369, 0.39919238669549, 0.689751452535042, 0.39919238669549, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0190000000000055), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.185000000000059), 4.2-0, UM.FS
OR	7	7	0.813	0.966	1.148	.70	.00 [.00, .71]	random (all)	glmer	c(0, 7, 45, 2, 179, 0, 0), c(23, 148, 60, 27, 526, 9, 4), c(2, 41, 69, 2, 5583, 120, 635), c(55, 1048, 87, 149, 16005, 5468, 6090), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 0.167014608116561, 1, 0.682778764173315, FALSE, c(0.5, 0, 0, 0, 0, 0.5, 0.5), c(0.5, 0, 0, 0, 0, 0.5, 0.5), NA, c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), OR, 0, c(-0.786756679682253, 0.1983090846914, -0.245122458032985, 1.77155676191054, -0.0377462839473047, 0.848482694649035, -0.0472571148705747), c(1.5688354854077, 0.418727398196639, 0.398669284078461, 1.02313377477651, 0.0935066981738867, 1.4538737501552, 1.4913011391401), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), c(0.616025698505328, 0.63578553504354, 0.53865271084865, 0.0833625150007686, 0.686451980980324, 0.559488546463854, 0.97472045594073), c(NA, NA, NA, NA, NA, NA, NA), 0.95, c(-3.86161772874975, -0.622381535114174, -1.02649989656914, -0.233748588017944, -0.22101604468138, -2.00105749372333, -2.97015363768873), c(2.28810436938525, 1.01899970449697, 0.536254980503167, 3.77686211183901, 0.14552347678677, 3.6980228830214, 2.87563940794759), FALSE, NULL, 7, 7, 7, 7, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.408655134384659, 0.682792763377123, 0.95, -0.210230821665009, 0.137689057568878, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480658, 0.0887567003816478, -0.408655142565051, 0.682792757372983, classic, Inf, -0.210230818182708, 0.137689054086576, 0.088164704885491, , NA, 0.0745296759722754, NA, NA, NA, HTS, , NA, 0.0887567003816478, 5, 0.95, -0.264427243840144, 0.191885479744013, 0.0745296759722754, 0.0745296759722754, c(Wald = 3.69099603661198, LRT = 5.99311853287482), c(6, 6), c(0.718409159065652, 0.423961391183092), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1, 1, 1.85085778575608, 0, 0, 0.70808668849877, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(5, 13, 16, 20, 39, 44, 50), study = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), profession = c("Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture", "Architecture"), pop = c("Faculty", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals"), group1 = c("Architecture", "Architects", "Architecture (freshmen)", "Architecture students (W)", "Architecture applicants", "Architects, except naval", "Architects, except naval"), group2 = c("Law, Psychology", "Non-architects", "HS seniors", "General students (W)", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music"), h = c("1i_3pt", "1i_3pt", "4i_3pt", "Writing hand", "EHI", "1i_2pt", "3i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(23, 148, 60, 27, 526, 9, 4), n_left_creative = c(0, 7, 45, 2, 179, 0, 0), n_right_creative = c(23, 141, 15, 25, 347, 9, 4), n_control = c(55, 1048, 87, 149, 16005, 5468, 6090), n_left_control = c(2, 41, 69, 2, 5583, 120, 635), n_right_control = c(53, 1007, 18, 147, 10422, 5348, 5455), PL_creative = c(0, 4.72972972972973, 75, 7.40740740740741, 34.0304182509506, 0, 0), PL_control = c(3.63636363636364, 3.91221374045802, 79.3103448275862, 1.34228187919463, 34.8828491096532, 2.1945866861741, 10.4269293924466), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0, 0.54736012451512, 0.360201254064835, 0.985202592325505, 0.801706664455788, 0, 0), effect = c(0, 1.21933921466874, 0.782608695652174, 5.88, 0.962957227606861, 0, 0), upper = c(4.73704496995417, 2.71900498756244, 1.69867400265703, 35.1639182075498, 1.15664078061488, 19.1649004245487, 8.27063753472762), chi_sq = c(0.02, 0.06, 0.17, 1.55, 0.13, 0, 0), p = c(0.887880413534634, 0.802098276857206, 0.678506486761815, 0.213508717330893, 0.720942262780942, 0.999999999999994, 0.999999999999984), correction = c(NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "success", "pref", "pref", "preference", "mix", "mix"), include = c(1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA), se = c(1.20845204486393, 0.55400121639402, 0.341453404029332, 8.71922032364412, 0.090546081193013, 4.88909504861288, 2.10989528378209), inv_var = c(0.684764375218916, 3.25820618247439, 8.57703350673165, 0.0131536019805634, 121.972150834508, 0.0418353145911693, 0.224635400028762), .event.e = c(0, 7, 45, 2, 179, 0, 0), .n.e = c(23, 148, 60, 27, 526, 9, 4), .event.c = c(2, 41, 69, 2, 5583, 120, 635), .n.c = c(55, 1048, 87, 149, 16005, 5468, 6090), .studlab = c("shettel-neuber_1983", "schacter_1996", "gotestam_1990", "wood_1991", "cosenza_1993", "nlsy79", "nlsy97"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(-0.501490874601039, 0.473599495866453, -0.614851627206732, 1.73150061662025, -0.403674653093953, 0.583601357792218, -0.0316885125547638), FALSE, -0.408655134384659, -0.408655142565051, c(NA, NA, NA, NA, NA, NA, NA), -0.0362708820480657, 0.0887567021583648, -0.210230821665009, 0.137689057568878, -0.408655134384659, 0.682792763377123, -0.408655134384659, Common effect model, common, NA, 0.0745296759722754, NA, 1, FALSE, FALSE, list(b = -0.0362708820480657, beta = -0.0362708820480657, se = 0.0887567021583648, zval = -0.408655134384659, pval = 0.682792763377123, ci.lb = -0.210230821665009, ci.ub = 0.137689057568878, vb = 0.00787775217802868, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999018858944, QMdf = c(1, NA), QMp = 0.682792763377123, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 8, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192463554, 5.99311853287482, 79.1916384927109, 84.304097129633, 107.991638492711), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0220000000000482), list(b = -0.0362708820480658, beta = -0.0362708820480658, se = 0.0887567003816478, zval = -0.408655142565051, pval = 0.682792757372983, ci.lb = -0.210230818182708, ci.ub = 0.137689054086576, vb = 0.00787775186263761, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.227256218791417, QE.Wld = 3.69099603661198, QEp.Wld = 0.718409159065652, QE.LRT = 5.99311853287482, QEp.LRT = 0.423961391183092, QE.df = 6, QM = 0.166999025544862, QMdf = c(1, NA), QMp = 0.682792757372983, k = 7, k.f = 7, k.yi = 7, k.eff = 14, k.all = 7, p = 1, p.eff = 8, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X = c(1, 1, 1, 1, 1, 1, 1), yi.f = c(-0.786756679682253, 0.198309084691399, -0.245122458032985, 1.77155676191054, -0.0377462839473048, 0.848482694649036, -0.0472571148705745), vi.f = c(2.46124478027441, 0.175332634000526, 0.158937198067633, 1.04680272108844, 0.00874350260338234, 2.11374888139033, 2.22397908760057), X.f = c(1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ti = NA), outdat = list(ai = c(0, 7, 45, 2, 179, 0, 0), bi = c(23, 141, 15, 25, 347, 9, 4), ci = c(2, 41, 69, 2, 5583, 120, 635), di = c(53, 1007, 18, 147, 10422, 5348, 5455), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(78, 1196, 147, 176, 16531, 5477, 6094), ni.f = c(78, 1196, 147, 176, 16531, 5477, 6094), ids = 1:7, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:7, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-31.5958192464879, 5.99311853313978, 81.1916384929758, 86.9431544595132, 126.191638492976), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(0, 7, 45, 2, 179, 0, 0), ci = c(2, 41, 69, 2, 5583, 120, 635), n1i = c(23, 148, 60, 27, 526, 9, 4), n2i = c(55, 1048, 87, 149, 16005, 5468, 6090), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.205000000000041), 4.2-0, UM.FS
Art
OR	8	8	1.306	1.928	2.845	<.001	.71 [.40, .86]	random	GLMM	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0319999999999254), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.437999999999988), 4.2-0, UM.FS
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	Inverse	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Inverse, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 5.29672404520868, 1.17898659523565e-07, 0.95, 0.372347043518412, 0.809769442358692, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.29672404520868, 2.56084885476388, c(7.85285677015393, 0.644246353322528, 1.51141868512111, 12.1163464079305, 0.96868264232281, 7.85178901280589, 35.6012311658001, 13.7605648851838), 0.591058242938552, 0.111589397124287, 0.372347043518412, 0.809769442358692, 5.29672404520868, 1.17898659523565e-07, 5.29672404520868, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.926	3.181	.01	.71 [.40, .86]	random	MH	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), MH, Inverse, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), 8, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 5.87874623167465, 4.13385540515412e-09, 0.95, 0.418365342813119, 0.836853001775561, c(2.32627106665439, 0.539161574267316, 1.03717186467078, 2.59697456573478, 0.749142137959842, 2.32617735806192, 3.02462735260728, 2.66523269943177), 0.655449106668746, 0.255949938415706, 2.56084885476388, 0.0104416772352013, classic, Inf, 0.153796445528717, 1.15710176780878, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.87874623167465, 2.56084885476388, c(5.51470588235294, 0.697674418604651, 0.646153846153846, 10.7793348281016, 0.914534567229178, 7.11363267952667, 29.1240045506257, 6.72689938398357), 0.62760917229434, 0.106759017579767, 0.418365342813119, 0.836853001775561, 5.87874623167465, 4.13385540515412e-09, 5.87874623167465, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.199	1.933	3.116	.007	.71 [.41, .86]	random	Peto	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), Peto, Peto, 0, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.737734224795348, -0.12052903696899, 1.886625, 0.190703412437214, 0.0609904207495266, 0.117134174635773, 0.371336934921835, 1.50046978291384), c(0.342493017102583, 1.21687522422527, 0.673934343983151, 0.294238027642615, 1.04464964727608, 0.372381982228678, 0.17013786477182, 0.233931487850484), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), c(0.0312391951359797, 0.921100172165413, 0.00511945666092442, 0.51690324668251, 0.953443067420015, 0.753100447472451, 0.0290678656470361, 1.41618155288198e-10), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0664602463178242, -2.50556065012963, 0.565737957848396, -0.385992524624412, -1.98648526437405, -0.61272109902407, 0.0378728475625207, 1.04197249187702), c(1.40900820327287, 2.26450257619165, 3.2075120421516, 0.767399349498841, 2.10846610587311, 0.846989448295615, 0.704801022281149, 1.95896707395066), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 5.86396181097839, 4.51951467668089e-09, 0.95, 0.426214879742889, 0.854168916148306, c(2.56799826388559, 0.57048573535209, 1.37685214872971, 2.78797780291132, 0.733460583896562, 2.43442133368832, 3.32166554888682, 3.05968680490349), 0.659207927166043, 0.243594349900081, 2.70617084278204, 0.00680640200487933, classic, Inf, 0.181771774524437, 1.13664407980765, 0.243594349900081, , NA, 0.234144502384702, NA, NA, NA, HTS, , NA, 0.57571269179161, 6, 0.95, -0.749510281233418, 2.06792613556551, 0.234144502384702, 0.234144502384702, 24.5275098344813, 7, 0.000919864214315797, REML, NULL, QP, 0.272106896186699, 0.236777542936739, 0.038761825825206, 1.77860140203637, 0.521638664390111, 0.196880232184966, 1.33364215666586, NULL, , , , 1.8718787290726, 1.30390385731621, 2.68726099450806, 0.714606168859455, 0.411821886871513, 0.861522152839296, 0.573211823699272, 0.278633686271807, 0.867789961126736, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.272106896186699, m4 = NULL), c(2.15401245560105, -0.0990479833671733, 2.79941958269924, 0.648126328078997, 0.0583836130214174, 0.314553818997186, 2.18256491827878, 6.41414200670948), FALSE, 5.86396181097839, 2.70617084278204, c(8.52504258972014, 0.675317341647313, 2.20173386541902, 11.5505429295484, 0.916344285972613, 7.2114514029265, 34.5460218820105, 18.2735377164244), 0.640191897945597, 0.109173954159634, 0.426214879742889, 0.854168916148306, 5.86396181097839, 4.51951467668089e-09, 5.86396181097839, Common effect model, common, NA, 0.234144502384702, NA, 1, FALSE, FALSE
OR	8	8	1.166	1.982	3.367	.01	.71 [.40, .86]	random	SSW	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), SSW, SSW, 0.5, only0, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 4.72688278677217, 2.27992782863981e-06, 0.95, 0.400373538518923, 0.967587665096766, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.27050562547953, 2.52852634985073, 0.0114542488124973, classic, Inf, 0.153799318252485, 1.2141618853632, 0.255949938415706, , NA, 0.247147389760076, NA, NA, NA, HTS, , NA, 0.606663577170735, 6, 0.95, -0.829003189968325, 2.13990140330582, 0.247147389760076, 0.247147389760076, 24.1590789829344, 7, 0.00106825988992507, REML, NULL, QP, 0.302530324890588, 0.261224267130059, 0.0440179401230728, 2.03974866182698, 0.550027567391479, 0.20980452836646, 1.42819769703882, NULL, , , , 1.85776666930001, 1.29242694444151, 2.67040006586481, 0.710253855085093, 0.401329314749629, 0.859767931583387, 0.577256548062485, 0.26796004488985, 0.88655305123512, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.302530324890588, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 4.72688278677217, 2.52852634985073, c(50.9950980392157, 19.8255813953488, 30.7692307692308, 50.8380044843049, 42.6644892034114, 77.0137785702707, 145.483503981797, 121.047227926078), 0.683980601807844, 0.14470014016889, 0.400373538518923, 0.967587665096766, 4.72688278677217, 2.27992782863981e-06, 4.72688278677217, Common effect model, common, NA, 0.247147389760076, NA, 1, FALSE, FALSE
OR	8	8	1.506	1.846	2.262	<.001	.71 [.40, .86]	random	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.270999999999958), 4.2-0, UM.FS
OR	8	8	1.498	1.836	2.25	<.001	.71 [.40, .86]	random (all)	glmer	c(28, 1, 8, 20, 1, 9, 84, 69), c(103, 31, 50, 51, 43, 78, 184, 225), c(15, 2, 2, 5583, 120, 636, 256, 21), c(101, 55, 80, 16005, 5468, 6091, 695, 262), GLMM, GLMM, 0.5, only0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 34.4457666506963, 1, 4.38295032687889e-09, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0), NA, c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), OR, 0, c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.112207407666009, 0.364968581450831, 1.62452499311495), c(0.356850378577675, 1.24587369257948, 0.813406439997887, 0.287285799440795, 1.01603633937568, 0.356874641625254, 0.167597482775787, 0.269576399645543), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), c(0.0329588476609907, 0.920685071461201, 0.0136878532708386, 0.517488118168704, 0.953445650782195, 0.753204445245946, 0.0294321382277291, 1.67845224375031e-09), c(NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(0.0615996019084648, -2.56592021541169, 0.411086242337315, -0.377132060946112, -1.93207805500383, -0.587254036915127, 0.0364835513107171, 1.09616495872771), c(1.46042738167192, 2.31781491807173, 3.59958089671491, 0.7490075794014, 2.05071120931667, 0.811668852247145, 0.693453611590945, 2.15288502750219), FALSE, NULL, 8, 8, 8, 8, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 5.82496654067666, 5.7124043232278e-09, 0.95, 0.40738332762278, 0.820555965128538, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.656371402867433, 0.198550483626267, 3.30581618780102, 0.00094700189757705, classic, Inf, 0.267219605846941, 1.04552319988793, 0.235458943998756, , NA, 0.24394386644034, NA, NA, NA, HTS, , NA, 0.437807264035059, 6, 0.95, -0.414904380017308, 1.72764718575217, 0.24394386644034, 0.24394386644034, c(Wald = 24.1590797864894, LRT = 26.9229022321632), c(7, 7), c(0.00106825954202226, 0.000344097617555269), ML, NULL, , 0.15225290589364, NA, NA, NA, 0.390195983953756, NA, NA, NULL, , , , 1.85776670019559, 1.29242696954756, 2.6704001028111, 0.710253864722337, 0.401329338008589, 0.859767935463746, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(3, 4, 11, 38, 45, 51, 57, 60), study = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), profession = c("Art", "Art", "Art", "Art", "Art", "Art", "Art", "Art"), pop = c("Students", "Faculty", "Professionals", "Students", "Professionals", "Professionals", "Military", "Students"), group1 = c("Art", "Art", "Writers, Painters", "Fine Arts applicants", "Artistic occupations", "Artistic occupations", "Art Hobbies", "Science/Visual Art"), group2 = c("Non-Art", "Law, Psychology", "Noncreatives", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies", "Lang/Lit"), h = c("HPQ", "1i_3pt", "AHQ", "EHI", "2i_2pt", "4i_3pt", "AHQ", "13i_3pt"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(103, 31, 50, 51, 43, 78, 184, 225), n_left_creative = c(28, 1, 8, 20, 1, 9, 84, 69), n_right_creative = c(75, 30, 42, 31, 42, 69, 100, 156), n_control = c(101, 55, 80, 16005, 5468, 6091, 695, 262), n_left_control = c(15, 2, 2, 5583, 120, 636, 256, 21), n_right_control = c(86, 53, 78, 10422, 5348, 5455, 439, 241), PL_creative = c(27.1844660194175, 3.2258064516129, 16, 39.2156862745098, 2.32558139534884, 11.5384615384615, 45.6521739130435, 30.6666666666667), PL_control = c(14.8514851485149, 3.63636363636364, 2.5, 34.8828491096532, 2.1945866861741, 10.4416351994746, 36.8345323741007, 8.01526717557252), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(1.06929827167943, 0.110651241887946, 1.67987422756774, 0.690636202130481, 0.1830194849695, 0.562813498592441, 1.03745938361973, 3.00245314669162), effect = c(2.14044444444444, 0.883333333333333, 7.42857142857143, 1.20434729853877, 1.06111111111111, 1.1187448728466, 1.44046875, 5.07600732600733), upper = c(4.28030757692179, 7.17252817670378, 32.3610554643716, 2.10016852725539, 6.16442467777959, 2.22380965213288, 2.00003031683707, 8.58159948376588), chi_sq = c(3.95, 0, 6.11, 0.25, 0, 0.02, 4.4, 39.74), p = c(0.0468511198471503, 0.999999999999999, 0.0134367644268677, 0.616354994623377, 0.999999999999885, 0.897853612835423, 0.0358442262031739, 2.90713751936831e-10), correction = c(NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "SR/(M+SL)"), pref_success = c("preference", "mix", "mix", "preference", "mix", "mix", "preference", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA), se = c(0.819150078922469, 1.80153232164443, 7.82697577068077, 0.359581180124512, 1.52589671034536, 0.423731294718211, 0.245558321686005, 1.42327776966359), inv_var = c(1.49029774780901, 0.308117158028698, 0.016323452551479, 7.7340342886758, 0.429486706960766, 5.56953477459766, 16.5840533845998, 0.493651735043577 ), .event.e = c(28, 1, 8, 20, 1, 9, 84, 69), .n.e = c(103, 31, 50, 51, 43, 78, 184, 225), .event.c = c(15, 2, 2, 5583, 120, 636, 256, 21), .n.c = c(101, 55, 80, 16005, 5468, 6091, 695, 262), .studlab = c("mebert_1980", "shettel-neuber_1983", "preti_2007", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004", "coren_1982"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0.237827036322463, m4 = NULL), c(2.13258423550906, -0.0995708067429674, 2.46535246208688, 0.647222242065476, 0.0583803697344796, 0.314416869618424, 2.17764954106792, 6.02621370138851), FALSE, 5.82496654067666, 3.30581618780102, c(NA, NA, NA, NA, NA, NA, NA, NA), 0.613969646375659, 0.105403119844245, 0.40738332762278, 0.820555965128538, 5.82496654067666, 5.7124043232278e-09, 5.82496654067666, Common effect model, common, NA, 0.24394386644034, NA, 1, FALSE, FALSE, list(b = 0.613969646375659, beta = 0.613969646375659, se = 0.105403119844245, zval = 5.82496654067666, pval = 5.7124043232278e-09, ci.lb = 0.40738332762278, ci.ub = 0.820555965128538, vb = 0.0111098176729003, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 33.9302352000027, QMdf = c(1, NA), QMp = 5.71240432322777e-09, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 9, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-52.627708947385, 26.9229022321632, 123.25541789477, 130.208716394928, 153.25541789477), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0169999999999391), list(b = 0.656371402867433, beta = 0.656371402867433, se = 0.198550483626267, zval = 3.30581618780102, pval = 0.00094700189757705, ci.lb = 0.267219605846941, ci.ub = 1.04552319988793, vb = 0.0394222945482244, tau2 = 0.15225290589364, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 56.1019857403788, H2 = 2.2780073697316, vt = 0.119133042187084, QE.Wld = 24.1590797864894, QEp.Wld = 0.00106825954202226, QE.LRT = 26.9229022321632, QEp.LRT = 0.000344097617555269, QE.df = 7, QM = 10.9284206675272, QMdf = c(1, NA), QMp = 0.000947001897577046, k = 8, k.f = 8, k.yi = 8, k.eff = 16, k.all = 8, p = 1, p.eff = 9, parms = 10, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534 ), X = c(1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(0.761013491790191, -0.124052648669979, 2.00533356952611, 0.185937759227644, 0.0593165771564195, 0.11220740766601, 0.364968581450831, 1.62452499311495), vi.f = c(0.12734219269103, 1.55220125786164, 0.661630036630037, 0.082533130560337, 1.03232984293194, 0.127359509835153, 0.0280889162327801, 0.0726714352458534), X.f = c(1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ti = NA), outdat = list(ai = c(28, 1, 8, 20, 1, 9, 84, 69), bi = c(75, 30, 42, 31, 42, 69, 100, 156), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), di = c(86, 53, 78, 10422, 5348, 5455, 439, 241), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(204, 86, 130, 16056, 5511, 6169, 879, 487 ), ni.f = c(204, 86, 130, 16056, 5511, 6169, 879, 487), ids = 1:8, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:8, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-41.5298225854411, 4.72712950827534, 103.059645170882, 110.78553239328, 147.059645170882), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(28, 1, 8, 20, 1, 9, 84, 69), ci = c(15, 2, 2, 5583, 120, 636, 256, 21), n1i = c(103, 31, 50, 51, 43, 78, 184, 225), n2i = c(101, 55, 80, 16005, 5468, 6091, 695, 262), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.265999999999963), 4.2-0, UM.FS
Music
OR	11	8	1.24	1.413	1.609	<.001	.10 [.00, .50]	random	GLMM	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0320000000000391), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.379999999999995), 4.2-0, UM.FS
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	Inverse	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Inverse, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, 0.95, 0.226707962816201, 0.488123152611205, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.35945612940463, 5.35945612940463, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 0.226707962816201, 0.488123152611205, 5.35945612940463, 8.34728604234335e-08, 5.35945612940463, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.254	1.43	1.629	<.001	.17 [.00, .57]	random	MH	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), MH, Inverse, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 11, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 5.18766442364861, 2.12947884198379e-07, 0.95, 0.214634084356199, 0.475299584844259, c(0.953711790393013, 7.75727875468434, 54.4338335603833, 33.9413143969245, 51.1516656971336, 17.8489889716194, 19.8068303314417, 2.39841666483754, 0.478815817963196, 0.478763628445952, 35.6012311658001), 0.357415557713703, 0.0666887738389618, 5.35945612940463, 8.34728604234335e-08, classic, Inf, 0.226707962816201, 0.488123152611205, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.18766442364861, 5.35945612940463, c(0.509090909090909, 9.06857142857143, 40.7445627024526, 25.2279293739968, 39.1837888784166, 20.314629258517, 14.3518518518519, 1.39444270995941, 0.262773722627737, 1.14489427962629, 29.1240045506257), 0.344966834600229, 0.0664975230525041, 0.214634084356199, 0.475299584844259, 5.18766442364861, 2.12947884198379e-07, 5.18766442364861, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.182	1.406	1.673	<.001	.34 [.00, .68]	random	Peto	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), Peto, Peto, 0, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.17826257861635, -0.301878909223286, 0.490670728524915, 0.452618839163683, 0.441543762495517, -0.172032692354803, 0.516686677945751, 1.10546580074985, -1.02444480232342, -1.11800549988975, 0.371336934921835), c(1.13845897443781, 0.355932285189848, 0.14336525247808, 0.187599135268246, 0.14795773771552, 0.22726902886927, 0.244167347549023, 0.663625553755456, 1.97448261801463, 0.988187320844407, 0.17013786477182), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), c(0.300686329135404, 0.396362352687967, 0.000620430801829795, 0.0158352163799149, 0.00284268850445013, 0.449076125152964, 0.0343348569588449, 0.0957537505474681, 0.603870823550084, 0.257899388302445, 0.0290678656470361), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-1.05307600915816, -0.999493369130427, 0.209679997033387, 0.0849312905070628, 0.151551925339074, -0.617471803739965, 0.0381274705489931, -0.195216383831291, -4.89435962173246, -3.05481705872391, 0.0378728475625207), c(3.40960116639086, 0.395735550683856, 0.771661460016443, 0.820306387820303, 0.731535599651959, 0.273406419030359, 0.995245885342509, 2.406147985331, 2.84547001708561, 0.818806058944414, 0.704801022281149), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 5.20883577784693, 1.90029208094365e-07, 0.95, 0.226555516539067, 0.499906194045163, c(0.760520908389271, 6.87345705765463, 25.4110227662677, 18.5209740001616, 24.5755209358123, 14.1943399067026, 12.7523207953466, 2.17770850151917, 0.255272590644762, 1.00470847959426, 20.9440320370434), 0.341026864449578, 0.0885719517845025, 3.85028056375345, 0.000117982595131526, classic, Inf, 0.167429028911534, 0.514624699987621, 0.0885719517845025, , NA, 0.098861981477167, NA, NA, NA, HTS, , NA, 0.163231111784296, 9, 0.95, -0.0282275642647816, 0.710281293163937, 0.098861981477167, 0.098861981477167, 15.2376327952008, 10, 0.123635383699418, REML, NULL, QP, 0.018799405211421, 0.0316117385422144, 0, 0.778484511672533, 0.13711092302009, 0, 0.882317693165298, NULL, , , , 1.23440806847658, 1, 1.76110216026958, 0.343730083642025, 0, 0.677573372724364, 0.217850717125471, 0, 0.57232693717241, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0.018799405211421, m4 = NULL), c(1.03496270403437, -0.848135788138097, 3.42252198523445, 2.41269150050446, 2.98425597277297, -0.756956164290033, 2.11611701209153, 1.66579751863686, -0.518842147799465, -1.13137001083399, 2.18256491827878), FALSE, 5.20883577784693, 3.85028056375345, c(0.771552050951551, 7.89342040816327, 48.6532876573287, 28.4143899075398, 45.679846451436, 19.3606301049807, 16.7735438837396, 2.27066883094076, 0.256503544194642, 1.02405066856933, 34.5460218820105), 0.363230855292115, 0.0697335970615408, 0.226555516539067, 0.499906194045163, 5.20883577784693, 1.90029208094365e-07, 5.20883577784693, Common effect model, common, NA, 0.098861981477167, NA, 1, FALSE, FALSE
OR	11	8	1.259	1.443	1.656	<.001	.17 [.00, .57]	random	SSW	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), SSW, SSW, 0.5, only0, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, 0.95, 0.229942155875115, 0.504183860507076, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 5.24668760411165, 1.54858150940595e-07, classic, Inf, 0.229942155875115, 0.504183860507076, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0666887738389618, 9, 0.95, 0.206555070295666, 0.50827604513174, 0.0732230364260747, 0.0732230364260747, 12.0556325886885, 10, 0.2813504774655, REML, NULL, QP, 0, 0.0171464064127715, 0, 0.366761810380963, 0, 0, 0.605608628060204, NULL, , , , 1.0979814474156, 1, 1.53068122690158, 0.170512212740895, 0, 0.573194027212509, 0, 0, 0.49248294798812, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = sub_input, method = method_var, sm = "OR", MH.exact = T), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.24668760411165, 5.24668760411165, c(21.8181818181818, 43.7485714285714, 443.393799167052, 272.379882289995, 423.276154571159, 116.008016032064, 96, 9.99375585388698, 11.9737226277372, 10.9801671857073, 145.483503981797), 0.367063008191096, 0.0699609040765913, 0.229942155875115, 0.504183860507076, 5.24668760411165, 1.54858150940595e-07, 5.24668760411165, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE
OR	11	8	1.243	1.416	1.612	<.001	.10 [.00, .50]	random	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0199999999999818), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.285000000000082), 4.2-0, UM.FS
OR	11	8	1.246	1.417	1.612	<.001	.10 [.00, .50]	random (all)	glmer	c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), GLMM, GLMM, 0.5, only0, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, 27.1567543211017, 1, 1.87608602209228e-07, FALSE, c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), c(0, 0, 0, 0, 0, 0, 0, 0, 0.5, 0.5, 0), NA, c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), OR, 0, c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947275, -0.985526753463505, 0.364968581450831), c(1.02397988189944, 0.359042038531597, 0.135539393972401, 0.171646784341226, 0.13982026139236, 0.236697237555309, 0.224694534815764, 0.645710254456962, 1.44515941110162, 1.44523817660532, 0.167597482775787), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), c(0.317062719150618, 0.395858042604062, 0.000667956267719317, 0.016390697823439, 0.00297932931833933, 0.449324195379823, 0.0355095764845638, 0.110798861839944, 0.691205424969968, 0.495293941606134, 0.0294321382277291), c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.95, c(-0.982459372902099, -1.00855115719238, 0.195507551223988, 0.0755475317545198, 0.141204294284106, -0.642989503982276, 0.032026866395486, -0.235911044916875, -2.25841454873102, -3.81814152869228, 0.0364835513107171), c(3.03146800593087, 0.398867771723165, 0.726812212568571, 0.748390562496355, 0.689289647560109, 0.284846617714778, 0.912813257919242, 2.2952266414508, 3.40650624662557, 1.84708802176527, 0.693453611590945), FALSE, NULL, 11, 11, 11, 11, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, NULL, NULL, NULL, NULL, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 5.19467998124439, 2.05072293454724e-07, 0.95, 0.215127608897207, 0.475825837705134, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723321432, 0.0665058730197768, 5.19467992275958, 2.05072357920626e-07, classic, Inf, 0.215127607442276, 0.475825839200589, 0.0666887738389618, , NA, 0.0732230364260747, NA, NA, NA, HTS, , NA, 0.0665058730197768, 9, 0.95, 0.195029986301596, 0.495923460341268, 0.0732230364260747, 0.0732230364260747, c(Wald = 11.1684167110754, LRT = 15.7409568135955), c(10, 10), c(0.344548281063998, 0.107291818931227), ML, NULL, , 0, NA, NA, NA, 0, NA, NA, NULL, , , , 1.05680730083944, 1, 1.41920555167993, 0.104617936570789, 0, 0.503511267100247, NA, NA, NA, Harbord, Common effect model, Random effects model, Prediction interval, common, random, , , , Experimental, Control, , , FALSE, list(est_id = c(10, 17, 24, 25, 26, 33, 34, 40, 46, 52, 58), study = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), profession = c("Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music", "Music"), pop = c("Professionals", "Students", "Professionals", "Professionals", "Professionals", "Students", "Students", "Students", "Professionals", "Professionals", "Military"), group1 = c("Musicians", "Music (freshmen)", "Instrumental musicians", "Composers", "Choir Members", "Singers", "Instrumental musicians", "Music applicants", "Musicians and composers", "Musicians, singers and related workers", "Art Hobbies"), group2 = c("Noncreatives", "HS seniors", "British adults", "British adults", "British adults", "General students", "General students", "Non-art/music/ architecture applicants", "Non-art, architecture, music", "Non-art, architecture, music", "Non-Art Hobbies" ), h = c("AHQ", "4i_3pt", "EHI", "EHI", "EHI", "EHI", "EHI", "EHI", "1i_2pt", "3i_3pt", "AHQ"), rl_sm = c("S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M", "S/M"), n_creative = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n_left_creative = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), n_right_creative = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), n_control = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), n_left_control = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n_right_control = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), PL_creative = c(6.66666666666667, 73.8636363636364, 16.3723916532905, 15.7099697885196, 15.7534246575342, 18.6567164179104, 30.5555555555556, 60, 0, 0, 45.6521739130435), PL_control = c(2.5, 79.3103448275862, 10.9882964889467, 10.9882964889467, 10.9882964889467, 21.5277777777778, 21.5277777777778, 34.8828491096532, 2.1945866861741, 10.4269293924466, 36.8345323741007), es_type = c("OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR", "OR"), lower = c(0.464423731737014, 0.366465801257523, 1.21644740238544, 1.07872445942092, 1.15145485197177, 0.527187637804322, 1.03487564330809, 0.848654395830455, 0, 0, 1.03745938361973), effect = c(2.78571428571429, 0.737240075614367, 1.5859123896921, 1.50978770333609, 1.51474479241834, 0.836046167505179, 1.60387096774194, 2.80010746910263, 0, 0, 1.44046875), upper = c(16.7260278811785, 1.48463089912896, 2.06759297841139, 2.11310579753473, 1.9926545814883, 1.32585277817068, 2.48819701178341, 9.23886316626205, 14.3568173617392, 3.00482027847417, 2.00003031683707), chi_sq = c(0.22, 0.45, 11.23, 5.38, 8.47, 0.41, 3.98, 1.78, 0, 0.41, 4.4), p = c(0.639881327139418, 0.501524708120961, 0.00080341684132884, 0.0203672620812506, 0.00360316584342875, 0.519806182964881, 0.0460363507271698, 0.182195207371202, 0.999999999999738, 0.523910835874685, 0.0358442262031739), correction = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), method = c("Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score", "Score"), notes = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), comparison = c("(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/(ML+MR)", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M", "(SR+SL)/M"), pref_success = c("mix", "pref", "success", "success", "success", "preference", "preference", "preference", "mix", "mix", "preference"), include = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), exclude_rnr = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), model_obj = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), se = c(4.14844463411343, 0.285251439998739, 0.217132963345163, 0.263877639148698, 0.214595710980359, 0.203744851095766, 0.37075205971613, 2.14039871054073, 3.66252070828443, 0.766549870858805, 0.245558321686005), inv_var = c(0.0581071270447214, 12.289785670778, 21.2103815496508, 14.3613352417399, 21.7149045455822, 24.0894406156262, 7.27499761251456, 0.218278338160219, 0.0745486566836351, 1.70184173708771, 16.5840533845998 ), .event.e = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), .n.e = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), .event.c = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), .n.c = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), .studlab = c("preti_2007", "gotestam_1990", "aggleton_1994", "aggleton_1994", "aggleton_1994", "byrne_1974", "byrne_1974", "cosenza_1993", "nlsy79", "nlsy97", "giotakos_2004"), .incr = c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)), NULL, NULL, NULL, TRUE, meta::metabin(event.e = n_left_creative, n.e = n_creative, event.c = n_left_control, n.c = n_control, studlab = study, data = meta_sub_prof, method = "GLMM", sm = "OR", MH.exact = F), 6.5-0, list(tau2.calc = 0, m4 = NULL), c(1.00051215324072, -0.849041783467315, 3.4024047797512, 2.40009766979648, 2.96986264213062, -0.756542175917474, 2.10249912195114, 1.59461274024973, 0.397219742360248, -0.681913036492282, 2.17764954106792), FALSE, 5.19467998124439, 5.19467992275958, c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), 0.345476723301171, 0.0665058722671134, 0.215127608897207, 0.475825837705134, 5.19467998124439, 2.05072293454724e-07, 5.19467998124439, Common effect model, common, NA, 0.0732230364260747, NA, 1, FALSE, FALSE, list(b = 0.345476723301171, beta = 0.345476723301171, se = 0.0665058722671134, zval = 5.19467998124439, pval = 2.05072293454724e-07, ci.lb = 0.215127608897207, ci.ub = 0.475825837705134, vb = 0.0044230310460096, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9847001075412, QMdf = c(1, NA), QMp = 2.05072293454724e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 12, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "FE", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327911944, 15.7409568135955, 156.365265582389, 169.457775022689, 191.031932249056), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "FE", test = "z", level = 95, control = list(NULL)), time = 0.0209999999999582), list(b = 0.345476723321432, beta = 0.345476723321432, se = 0.0665058730197768, zval = 5.19467992275958, pval = 2.05072357920626e-07, ci.lb = 0.215127607442276, ci.ub = 0.475825839200589, vb = 0.00442303114612267, tau2 = 0, se.tau2 = NA, sigma2 = NA, rho = NA, ci.lb.tau2 = NA, ci.ub.tau2 = NA, I2 = 0, H2 = 1, vt = 0.0538168965136118, QE.Wld = 11.1684167110754, QEp.Wld = 0.344548281063998, QE.LRT = 15.7409568135955, QEp.LRT = 0.107291818931227, QE.df = 10, QM = 26.9846994999214, QMdf = c(1, NA), QMp = 2.05072357920626e-07, k = 11, k.f = 11, k.yi = 11, k.eff = 22, k.all = 11, p = 1, p.eff = 12, parms = 13, int.only = TRUE, int.incl = TRUE, intercept = TRUE, yi = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), yi.f = c(1.02450431651439, -0.304841692734607, 0.46115988189628, 0.411969047125437, 0.415246970922108, -0.179071443133749, 0.472420062157364, 1.02965779826696, 0.574045848947276, -0.985526753463505, 0.364968581450831), vi.f = c(1.0485347985348, 0.128911185432925, 0.0183709273184058, 0.0294626185746835, 0.0195497054958278, 0.0560255822663143, 0.0504876339760725, 0.416941732710875, 2.08848572349559, 2.08871338711748, 0.0280889162327801), X.f = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), outdat.f = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ti = NA), outdat = list(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), bi = c(28, 23, 521, 279, 492, 109, 75, 4, 12, 11, 100), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), di = c(78, 18, 1369, 1369, 1369, 678, 678, 10422, 5348, 5455, 439), x1i = NA, x2i = NA, t1i = NA, t2i = NA, xi = NA, mi = NA, ti = NA), ni = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ni.f = c(110, 175, 2161, 1869, 2122, 998, 972, 16015, 5480, 6101, 879), ids = 1:11, not.na = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), subset = NULL, not.na.yivi = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), slab = 1:11, slab.null = TRUE, measure = "OR", method = "ML", model = "UM.FS", weighted = TRUE, test = "z", dfs = NA, ddf = NA, btt = 1, m = 1, digits = c(est = 4, se = 4, test = 4, pval = 4, ci = 4, var = 4, sevar = 4, fit = 4, het = 4), level = 0.05, control = list(NULL), verbose = FALSE, add = 0.5, to = "only0", drop00 = TRUE, fit.stats = list(ML = c(-66.1826327914449, 15.7409568140964, 158.36526558289, 172.548817476548, 203.86526558289), REML = c(NA, NA, NA, NA, NA)), data = <environment>, se.warn = FALSE, formula.yi = NULL, formula.mods = NULL, version = list(c(4, 2, 0)), call = (function (ai, bi, ci, di, n1i, n2i, x1i, x2i, t1i, t2i, xi, mi, ti, ni, mods, measure, intercept = TRUE, data, slab, subset, add = 1/2, to = "only0", drop00 = TRUE, vtype = "LS", model = "UM.FS", method = "ML", coding = 1/2, cor = FALSE, test = "z", level = 95, btt, nAGQ = 7, verbose = FALSE, digits, control, ...) { mstyle <- .get.mstyle("crayon" %in% .packages()) if (missing(measure)) stop(mstyle$stop("Must specify 'measure' argument.")) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN", "PR", "RR", "RD", "PLN"))) stop(mstyle$stop("Unknown 'measure' specified.")) if (!is.element(method, c("FE", "EE", "CE", "ML"))) stop(mstyle$stop("Unknown 'method' specified.")) if (!is.element(coding, c(1/2, 1, 0))) stop(mstyle$stop("Unknown 'coding' option specified.")) if (length(add) > 1) add <- add[1] if (length(to) > 1) to <- to[1] if (!is.element(model, c("UM.FS", "UM.RS", "CM.EL", "CM.AL"))) stop(mstyle$stop("Unknown 'model' specified.")) if (model == "CM.AL" && measure == "IRR") model <- "CM.EL" if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && !is.null(match.call()$model)) warning(mstyle$warning("Argument 'model' not relevant for this outcome measure."), call. = FALSE) if (!is.element(measure, c("OR", "IRR", "PLO", "IRLN"))) warning(mstyle$warning("The use of this 'measure' is experimental - treat results with caution."), call. = FALSE) if (is.element(model, c("CM.EL", "CM.AL")) && is.element(measure, c("RR", "RD"))) stop(mstyle$stop("Cannot use this measure with model='CM.EL' or model='CM.AL'.")) na.act <- getOption("na.action") on.exit(options(na.action = na.act), add = TRUE) if (!is.element(na.act, c("na.omit", "na.exclude", "na.fail", "na.pass"))) stop(mstyle$stop("Unknown 'na.action' specified under options().")) if (missing(control)) control <- list() time.start <- proc.time() ddd <- list(...) .chkdots(ddd, c("tdist", "outlist", "onlyo1", "addyi", "addvi", "time", "retdat", "family", "retfit", "skiphet", "i2def", "link")) if (.isFALSE(ddd$tdist)) test <- "z" if (.isTRUE(ddd$tdist)) test <- "t" if (!is.element(test, c("z", "t"))) stop(mstyle$stop("Invalid option selected for 'test' argument.")) onlyo1 <- ifelse(is.null(ddd$onlyo1), FALSE, ddd$onlyo1) addyi <- ifelse(is.null(ddd$addyi), TRUE, ddd$addyi) addvi <- ifelse(is.null(ddd$addvi), TRUE, ddd$addvi) i2def <- ifelse(is.null(ddd$i2def), "1", ddd$i2def) if (missing(digits)) { digits <- .set.digits(dmiss = TRUE) } else { digits <- .set.digits(digits, dmiss = FALSE) } formula.mods <- NULL if (verbose > 2) { opwarn <- options(warn = 1) on.exit(options(warn = opwarn$warn), add = TRUE) } if (is.null(ddd$link)) { if (measure == "OR" || measure == "PLO") link <- "logit" if (measure == "RR" || measure == "PLN") link <- "log" if (measure == "RD" || measure == "PR") link <- "identity" if (measure == "IRR" || measure == "IRLN") link <- "log" } else { link <- ddd$link } if (verbose) .space() if (verbose > 1) message(mstyle$message("Extracting data and computing yi/vi values ...")) if (missing(data)) data <- NULL if (is.null(data)) { data <- sys.frame(sys.parent()) } else { if (!is.data.frame(data)) data <- data.frame(data) } mf <- match.call() slab <- .getx("slab", mf = mf, data = data) subset <- .getx("subset", mf = mf, data = data) mods <- .getx("mods", mf = mf, data = data) ai <- bi <- ci <- di <- x1i <- x2i <- t1i <- t2i <- xi <- mi <- ti <- NA if (is.element(measure, c("OR", "RR", "RD"))) { ai <- .getx("ai", mf = mf, data = data, checknumeric = TRUE) bi <- .getx("bi", mf = mf, data = data, checknumeric = TRUE) ci <- .getx("ci", mf = mf, data = data, checknumeric = TRUE) di <- .getx("di", mf = mf, data = data, checknumeric = TRUE) n1i <- .getx("n1i", mf = mf, data = data, checknumeric = TRUE) n2i <- .getx("n2i", mf = mf, data = data, checknumeric = TRUE) if (is.null(bi)) bi <- n1i - ai if (is.null(di)) di <- n2i - ci k <- length(ai) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) ai <- .getsubset(ai, subset) bi <- .getsubset(bi, subset) ci <- .getsubset(ci, subset) di <- .getsubset(di, subset) } args <- list(measure = measure, ai = ai, bi = bi, ci = ci, di = di, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRR"))) { x1i <- .getx("x1i", mf = mf, data = data, checknumeric = TRUE) x2i <- .getx("x2i", mf = mf, data = data, checknumeric = TRUE) t1i <- .getx("t1i", mf = mf, data = data, checknumeric = TRUE) t2i <- .getx("t2i", mf = mf, data = data, checknumeric = TRUE) k <- length(x1i) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) x1i <- .getsubset(x1i, subset) x2i <- .getsubset(x2i, subset) t1i <- .getsubset(t1i, subset) t2i <- .getsubset(t2i, subset) } args <- list(measure = measure, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, add = add, to = to, drop00 = drop00, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("PLO", "PR", "PLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) mi <- .getx("mi", mf = mf, data = data, checknumeric = TRUE) ni <- .getx("ni", mf = mf, data = data, checknumeric = TRUE) if (is.null(mi)) mi <- ni - xi k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) mi <- .getsubset(mi, subset) } args <- list(measure = measure, xi = xi, mi = mi, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } if (is.element(measure, c("IRLN"))) { xi <- .getx("xi", mf = mf, data = data, checknumeric = TRUE) ti <- .getx("ti", mf = mf, data = data, checknumeric = TRUE) k <- length(xi) k.all <- k if (!is.null(subset)) { subset <- .chksubset(subset, k) xi <- .getsubset(xi, subset) ti <- .getsubset(ti, subset) } args <- list(measure = measure, xi = xi, ti = ti, add = add, to = to, vtype = vtype, onlyo1 = onlyo1, addyi = addyi, addvi = addvi) } dat <- .do.call(escalc, args) yi <- dat$yi vi <- dat$vi ni <- attr(yi, "ni") ids <- seq_len(k) if (verbose > 1) message(mstyle$message("Creating model matrix ...")) if (inherits(mods, "formula")) { formula.mods <- mods if (isTRUE(all.equal(formula.mods, ~1))) { mods <- matrix(1, nrow = k, ncol = 1) intercept <- FALSE } else { options(na.action = "na.pass") mods <- model.matrix(mods, data = data) attr(mods, "assign") <- NULL options(na.action = na.act) intercept <- FALSE } } if (.is.vector(mods)) mods <- cbind(mods) if (is.data.frame(mods)) mods <- as.matrix(mods) if (is.character(mods)) stop(mstyle$stop("Model matrix contains character variables.")) if (!is.null(mods) && nrow(mods) != k) stop(mstyle$stop(paste0("Number of rows in the model matrix (", nrow(mods), ") does not match length of the outcome vector (", k, ")."))) if (verbose > 1) message(mstyle$message("Generating/extracting study labels ...")) if (is.null(slab)) { slab.null <- TRUE slab <- ids } else { if (anyNA(slab)) stop(mstyle$stop("NAs in study labels.")) if (length(slab) != k) stop(mstyle$stop("Study labels not of same length as data.")) if (is.factor(slab)) slab <- as.character(slab) slab.null <- FALSE } if (!is.null(subset)) { if (verbose > 1) message(mstyle$message("Subsetting ...")) mods <- .getsubset(mods, subset) slab <- .getsubset(slab, subset) ids <- .getsubset(ids, subset) } if (anyDuplicated(slab)) slab <- .make.unique(slab) attr(yi, "slab") <- slab k <- length(yi) if (is.element(measure, c("OR", "RR", "RD"))) { if (drop00) { id00 <- c(ai == 0 & ci == 0) | c(bi == 0 & di == 0) id00[is.na(id00)] <- FALSE ai[id00] <- NA bi[id00] <- NA ci[id00] <- NA di[id00] <- NA } } if (is.element(measure, c("IRR"))) { if (drop00) { id00 <- c(x1i == 0 & x2i == 0) id00[is.na(id00)] <- FALSE x1i[id00] <- NA x2i[id00] <- NA } } outdat.f <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ni = ni, ti = ti) yi.f <- yi vi.f <- vi ni.f <- ni mods.f <- mods k.f <- k if (is.element(measure, c("OR", "RR", "RD"))) { has.na <- is.na(ai) | is.na(bi) | is.na(ci) | is.na(di) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { ai <- ai[not.na] bi <- bi[not.na] ci <- ci[not.na] di <- di[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(ai) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRR")) { has.na <- is.na(x1i) | is.na(x2i) | is.na(t1i) | is.na(t2i) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { x1i <- x1i[not.na] x2i <- x2i[not.na] t1i <- t1i[not.na] t2i <- t2i[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(x1i) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, c("PLO", "PR", "PLN"))) { has.na <- is.na(xi) | is.na(mi) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] mi <- mi[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (is.element(measure, "IRLN")) { has.na <- is.na(xi) | is.na(ti) | (if (is.null(mods)) FALSE else apply(is.na(mods), 1, any)) not.na <- !has.na if (any(has.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in table data ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { xi <- xi[not.na] ti <- ti[not.na] mods <- mods[not.na, , drop = FALSE] k <- length(xi) warning(mstyle$warning(paste(sum(has.na), ifelse(sum(has.na) > 1, "studies", "study"), "with NAs omitted from model fitting.")), call. = FALSE) } if (na.act == "na.fail") stop(mstyle$stop("Missing values in studies.")) } } if (k < 1) stop(mstyle$stop("Processing terminated since k = 0.")) mods.yi <- mods.f yivi.na <- is.na(yi) | is.na(vi) | (if (is.null(mods.yi)) FALSE else apply(is.na(mods.yi), 1, any)) not.na.yivi <- !yivi.na if (any(yivi.na)) { if (verbose > 1) message(mstyle$message("Handling NAs in yi/vi ...")) if (na.act == "na.omit" || na.act == "na.exclude" || na.act == "na.pass") { yi <- yi[not.na.yivi] ni <- ni[not.na.yivi] vi <- vi[not.na.yivi] mods.yi <- mods.f[not.na.yivi, , drop = FALSE] warning(mstyle$warning("Some yi/vi values are NA."), call. = FALSE) attr(yi, "measure") <- measure attr(yi, "ni") <- ni } if (na.act == "na.fail") stop(mstyle$stop("Missing yi/vi values.")) } k.yi <- length(yi) if (is.null(mods) && !intercept) { warning(mstyle$warning("Must either include an intercept and/or moderators in model.\nCoerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (!is.null(mods) && ncol(mods) == 0) { warning(mstyle$warning("Cannot fit model with an empty model matrix. Coerced intercept into the model."), call. = FALSE) intercept <- TRUE } if (intercept) { X <- cbind(intrcpt = rep(1, k), mods) X.f <- cbind(intrcpt = rep(1, k.f), mods.f) X.yi <- cbind(intrcpt = rep(1, k.yi), mods.yi) } else { X <- mods X.f <- mods.f X.yi <- mods.yi } tmp <- lm(rep(0, k) ~ X - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) { warning(mstyle$warning("Redundant predictors dropped from the model."), call. = FALSE) X <- X[, !coef.na, drop = FALSE] X.f <- X.f[, !coef.na, drop = FALSE] } tmp <- lm(yi ~ X.yi - 1) coef.na <- is.na(coef(tmp)) if (any(coef.na)) X.yi <- X.yi[, !coef.na, drop = FALSE] is.int <- apply(X, 2, .is.intercept) if (any(is.int)) { int.incl <- TRUE int.indx <- which(is.int, arr.ind = TRUE) X <- cbind(intrcpt = 1, X[, -int.indx, drop = FALSE]) X.f <- cbind(intrcpt = 1, X.f[, -int.indx, drop = FALSE]) intercept <- TRUE } else { int.incl <- FALSE } is.int <- apply(X.yi, 2, .is.intercept) if (any(is.int)) { int.indx <- which(is.int, arr.ind = TRUE) X.yi <- cbind(intrcpt = 1, X.yi[, -int.indx, drop = FALSE]) } p <- NCOL(X) colnames(X) <- colnames(X.f) <- .make.unique(colnames(X)) if ((p == 1) && .is.intercept(X)) { int.only <- TRUE } else { int.only <- FALSE } if (is.element(method, c("FE", "EE", "CE")) && p > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) if (!is.element(method, c("FE", "EE", "CE")) && (p + 1) > k) stop(mstyle$stop("Number of parameters to be estimated is larger than the number of observations.")) btt <- .set.btt(btt, p, int.incl, colnames(X)) m <- length(btt) con <- list(verbose = FALSE, package = "lme4", optimizer = "nlminb", optmethod = "BFGS", parallel = list(), cl = NULL, ncpus = 1, scaleX = TRUE, evtol = 1e-07, dnchgcalc = "dFNCHypergeo", dnchgprec = 1e-10, hesspack = "numDeriv", tau2tol = 1e-04) con.pos <- pmatch(names(control), names(con)) con[c(na.omit(con.pos))] <- control[!is.na(con.pos)] if (verbose) con$verbose <- verbose verbose <- con$verbose optimizer <- match.arg(con$optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "clogit", "clogistic", "Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent", "Rcgmin", "Rvmmin")) optmethod <- match.arg(con$optmethod, c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) if (optimizer %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN", "Brent")) { optmethod <- optimizer optimizer <- "optim" } package <- match.arg(con$package, c("lme4", "GLMMadaptive", "glmmTMB")) parallel <- con$parallel cl <- con$cl ncpus <- con$ncpus if (con$dnchgcalc != "dnoncenhypergeom" && con$dnchgcalc != "dFNCHypergeo") stop(mstyle$stop("Unknown dnchgcalc method specified.")) if (is.element(optimizer, c("clogit", "clogistic")) && method == "ML") stop(mstyle$stop("Cannot use 'clogit' or 'clogistic' with method='ML'.")) if (package == "lme4" && is.element(measure, c("OR", "RR", "RD", "IRR")) && model == "UM.RS" && method == "ML" && nAGQ > 1) { warning(mstyle$warning("Not possible to fit RE/ME model='UM.RS' with nAGQ > 1 with glmer(). nAGQ automatically set to 1."), call. = FALSE) nAGQ <- 1 } if (ncpus > 1) optimizer <- "optimParallel" pos.optCtrl <- pmatch(names(control), "optCtrl", nomatch = 0) if (sum(pos.optCtrl) > 0) { optCtrl <- control[[which(pos.optCtrl == 1)]] } else { optCtrl <- list() } if (optimizer == "nloptr" && !is.element("algorithm", names(optCtrl))) optCtrl$algorithm <- "NLOPT_LN_BOBYQA" if (optimizer == "nloptr" && !is.element("ftol_rel", names(optCtrl))) optCtrl$ftol_rel <- 1e-08 if (optimizer == "mads" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "mads" && !is.element("tol", names(optCtrl))) optCtrl$tol <- 1e-06 if (optimizer == "subplex" && !is.element("reltol", names(optCtrl))) optCtrl$reltol <- 1e-08 if (optimizer == "BBoptim" && !is.element("trace", names(optCtrl))) optCtrl$trace <- FALSE if (optimizer == "optim") { con.pos <- pmatch(names(optCtrl), "REPORT", nomatch = 0) if (sum(con.pos) > 0) { names(optCtrl)[which(con.pos == 1)] <- "REPORT" } else { optCtrl$REPORT <- 1 } optCtrl$trace <- con$verbose } if (optimizer == "nlminb") optCtrl$trace <- ifelse(con$verbose > 0, 1, 0) if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) optCtrl$iprint <- ifelse(con$verbose > 0, 3, 0) pos.clogitCtrl <- pmatch(names(control), "clogitCtrl", nomatch = 0) if (sum(pos.clogitCtrl) > 0) { clogitCtrl <- control[[which(pos.clogitCtrl == 1)]] } else { clogitCtrl <- list() } pos.clogisticCtrl <- pmatch(names(control), "clogisticCtrl", nomatch = 0) if (sum(pos.clogisticCtrl) > 0) { clogisticCtrl <- control[[which(pos.clogisticCtrl == 1)]] } else { clogisticCtrl <- list() } pos.glmCtrl <- pmatch(names(control), "glmCtrl", nomatch = 0) if (sum(pos.glmCtrl) > 0) { glmCtrl <- control[[which(pos.glmCtrl == 1)]] } else { glmCtrl <- list() } glmCtrl$trace <- ifelse(con$verbose > 0, TRUE, FALSE) pos.glmerCtrl <- pmatch(names(control), "glmerCtrl", nomatch = 0) if (sum(pos.glmerCtrl) > 0) { glmerCtrl <- control[[which(pos.glmerCtrl == 1)]] } else { glmerCtrl <- list() } pos.intCtrl <- pmatch(names(control), "intCtrl", nomatch = 0) if (sum(pos.intCtrl) > 0) { intCtrl <- control[[which(pos.intCtrl == 1)]] } else { intCtrl <- list() } con.pos <- pmatch(names(intCtrl), "lower", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "lower" } else { intCtrl$lower <- -Inf } con.pos <- pmatch(names(intCtrl), "upper", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "upper" } else { intCtrl$upper <- Inf } con.pos <- pmatch(names(intCtrl), "subdivisions", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "subdivisions" } else { intCtrl$subdivisions <- 100 } con.pos <- pmatch(names(intCtrl), "rel.tol", nomatch = 0) if (sum(con.pos) > 0) { names(intCtrl)[which(con.pos == 1)] <- "rel.tol" } else { intCtrl$rel.tol <- .Machine$double.eps^0.25 } pos.hessianCtrl <- pmatch(names(control), "hessianCtrl", nomatch = 0) if (sum(pos.hessianCtrl) > 0) { hessianCtrl <- control[[which(pos.hessianCtrl == 1)]] } else { hessianCtrl <- list(r = 16) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if ((model == "UM.FS" && method == "ML") || (model == "UM.RS") || (model == "CM.AL" && method == "ML") || (model == "CM.EL" && method == "ML")) { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN")) && method == "ML") { if (!requireNamespace(package, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", package, "' package to fit this model."))) } if (measure == "OR" && model == "CM.EL") { if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { if (!requireNamespace("minqa", quietly = TRUE)) stop(mstyle$stop("Please install the 'minqa' package to fit this model.")) } if (is.element(optimizer, c("nloptr", "ucminf", "lbfgsb3c", "subplex", "optimParallel"))) { if (!requireNamespace(optimizer, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", optimizer, "' package to use this optimizer."))) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { if (!requireNamespace("dfoptim", quietly = TRUE)) stop(mstyle$stop("Please install the 'dfoptim' package to use this optimizer.")) } if (optimizer == "BBoptim") { if (!requireNamespace("BB", quietly = TRUE)) stop(mstyle$stop("Please install the 'BB' package to use this optimizer.")) } if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { con$hesspack <- match.arg(con$hesspack, c("numDeriv", "pracma")) if (!requireNamespace(con$hesspack, quietly = TRUE)) stop(mstyle$stop(paste0("Please install the '", con$hesspack, "' package to fit this model."))) if (con$dnchgcalc == "dFNCHypergeo") { if (!requireNamespace("BiasedUrn", quietly = TRUE)) stop(mstyle$stop("Please install the 'BiasedUrn' package to fit this model.")) } } if (optimizer == "clogit") { if (!requireNamespace("survival", quietly = TRUE)) stop(mstyle$stop("Please install the 'survival' package to fit this model.")) coxph <- survival::coxph Surv <- survival::Surv clogit <- survival::clogit strata <- survival::strata } if (optimizer == "clogistic") { if (!requireNamespace("Epi", quietly = TRUE)) stop(mstyle$stop("Please install the 'Epi' package to fit this model.")) } } if (any(eigen(crossprod(X), symmetric = TRUE, only.values = TRUE)$values <= con$evtol)) stop(mstyle$stop("Model matrix not of full rank. Cannot fit model.")) se.tau2 <- ci.lb.tau2 <- ci.ub.tau2 <- I2 <- H2 <- QE <- QEp <- NA se.warn <- FALSE rho <- NA level <- .level(level) if (!int.only && int.incl && con$scaleX) { Xsave <- X meanX <- colMeans(X[, 2:p, drop = FALSE]) sdX <- apply(X[, 2:p, drop = FALSE], 2, sd) is.d <- apply(X, 2, .is.dummy) X[, !is.d] <- apply(X[, !is.d, drop = FALSE], 2, scale) } if (is.element(measure, c("OR", "RR", "RD", "IRR"))) { if (is.element(model, c("UM.FS", "UM.RS"))) { if (is.element(measure, c("OR", "RR", "RD"))) { dat.grp <- cbind(xi = c(rbind(ai, ci)), mi = c(rbind(bi, di))) if (is.null(ddd$family)) { if (measure == "OR") dat.fam <- binomial(link = link) if (measure == "RR") dat.fam <- binomial(link = link) if (measure == "RD") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRR"))) { dat.grp <- c(rbind(x1i, x2i)) if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(c(rbind(t1i, t2i))) } group1 <- rep(c(1, 0), times = k) group2 <- rep(c(0, 1), times = k) group12 <- rep(c(1/2, -1/2), times = k) study <- factor(rep(seq_len(k), each = 2)) const <- cbind(rep(1, 2 * k)) X.fit <- X[rep(seq(k), each = 2), , drop = FALSE] X.fit <- cbind(group1 * X.fit[, , drop = FALSE]) if (coding == 1/2) group <- group12 if (coding == 1) group <- group1 if (coding == 0) group <- group2 rownames(X.fit) <- seq_len(2 * k) if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, const = const, group1 = group1, group2 = group2, group12 = group12, group = group, dat.fam = dat.fam)) if (model == "UM.FS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (k > 1) { res.FE <- try(glm(dat.grp ~ -1 + X.fit + study, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.FE <- try(glm(dat.grp ~ -1 + X.fit + const, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(k + p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(k + p), -seq_len(k + p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + study, random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, group = group) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + study + offset(dat.off), random = ~group - 1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + study + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p + k p.eff <- p + k k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + k + 1 p.eff <- p + k k.eff <- 2 * k } } if (model == "UM.RS") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (package == "lme4") { if (verbose) { res.FE <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const) res.FE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.FE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.FE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + const + study:group1) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = TRUE) X.QE <- X.QE[, !is.na(coef(res.QE)), drop = FALSE] if (package == "lme4") { if (verbose) { res.QE <- try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = c(sqrt(lme4::VarCorr(res.FE)[[1]][1])), nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { glmerCtrl$max_coef_value <- 50 if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.QE <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.QE, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl, initial_values = list(D = matrix(res.FE$D[1, 1]))), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.QE <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.QE + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.QE <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.QE <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.QE + (1 | study), offset = dat.off, family = dat.fam, start = list(theta = sqrt(glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]])), verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) if (package == "lme4") { b2.QE <- cbind(lme4::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } if (package == "GLMMadaptive") { b2.QE <- cbind(GLMMadaptive::fixef(res.QE)[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE))[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] vb2.QE <- vb2.QE[-nrow(vb2.QE), -ncol(vb2.QE)] } if (package == "glmmTMB") { b2.QE <- cbind(glmmTMB::fixef(res.QE)$cond[-seq_len(p + 1)]) vb2.QE <- as.matrix(vcov(res.QE)$cond)[-seq_len(p + 1), -seq_len(p + 1), drop = FALSE] } } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { if (cor) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + const + (group || study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } } if (package == "GLMMadaptive") { if (is.element(measure, c("OR", "RR", "RD"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + const, random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } else { dat.mm <- data.frame(xi = dat.grp, study = study, const = const, group = group) if (cor) { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + const + offset(dat.off), random = ~group || study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } } if (package == "glmmTMB") { if (verbose) { if (cor) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } } else { if (cor) { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (group | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + const + (1 | study) + (group - 1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.ML <- c(logLik(res.ML)) } if (is.element(method, c("FE", "EE", "CE"))) { tau2 <- 0 if (package == "lme4") { beta <- cbind(lme4::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- lme4::VarCorr(res.FE)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.FE)[seq_len(p)]) vb <- as.matrix(vcov(res.FE))[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- res.FE$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.FE)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.FE)$cond)[seq_len(p), seq_len(p), drop = FALSE] sigma2 <- glmmTMB::VarCorr(res.FE)[[1]][[1]][[1]] } parms <- p + 1 + 1 p.eff <- p + 1 k.eff <- 2 * k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- lme4::VarCorr(res.ML)[[1]][2, 2] sigma2 <- lme4::VarCorr(res.ML)[[1]][1, 1] rho <- lme4::VarCorr(res.ML)[[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- lme4::VarCorr(res.ML)[[2]][1] sigma2 <- lme4::VarCorr(res.ML)[[1]][1] } } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[2, 2] sigma2 <- res.ML$D[1, 1] if (cor) rho <- res.ML$D[1, 2]/sqrt(tau2 * sigma2) } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] if (cor) { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][2, 2] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 1] rho <- glmmTMB::VarCorr(res.ML)[[1]][[1]][1, 2]/sqrt(tau2 * sigma2) } else { tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[2]][[1]] sigma2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } } parms <- p + 1 + 2 p.eff <- p + 1 k.eff <- 2 * k } } } if ((measure == "IRR" && model == "CM.EL") || (measure == "OR" && model == "CM.AL") || (measure == "OR" && model == "CM.EL")) { if (measure == "OR") { dat.grp <- cbind(xi = ai, mi = ci) dat.off <- log((ai + bi)/(ci + di)) } if (measure == "IRR") { dat.grp <- cbind(xi = x1i, mi = x2i) dat.off <- log(t1i/t2i) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = binomial, control = glmCtrl), silent = !verbose) } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = binomial, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = binomial, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { if (is.na(ll.QE)) { ll.ML <- c(logLik(res.ML)) } else { if (verbose) { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- ll.QE - 1/2 * suppressWarnings(deviance(res.ML)) } } } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (measure == "OR" && model == "CM.EL") { if (verbose) message(mstyle$message("Fitting FE model ...")) if (is.element(optimizer, c("optim", "nlminb", "uobyqa", "newuoa", "bobyqa", "nloptr", "nlm", "hjk", "nmk", "mads", "ucminf", "lbfgsb3c", "subplex", "BBoptim", "optimParallel", "Rcgmin", "Rvmmin"))) { if (optimizer == "optim") { par.arg <- "par" ctrl.arg <- ", control=optCtrl" } if (optimizer == "nlminb") { par.arg <- "start" ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("uobyqa", "newuoa", "bobyqa"))) { par.arg <- "par" optimizer <- paste0("minqa::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "nloptr") { par.arg <- "x0" optimizer <- paste0("nloptr::nloptr") ctrl.arg <- ", opts=optCtrl" } if (optimizer == "nlm") { par.arg <- "p" ctrl.arg <- paste(names(optCtrl), unlist(optCtrl), sep = "=", collapse = ", ") if (nchar(ctrl.arg) != 0) ctrl.arg <- paste0(", ", ctrl.arg) } if (is.element(optimizer, c("hjk", "nmk", "mads"))) { par.arg <- "par" optimizer <- paste0("dfoptim::", optimizer) ctrl.arg <- ", control=optCtrl" } if (is.element(optimizer, c("ucminf", "lbfgsb3c", "subplex"))) { par.arg <- "par" optimizer <- paste0(optimizer, "::", optimizer) ctrl.arg <- ", control=optCtrl" } if (optimizer == "BBoptim") { par.arg <- "par" optimizer <- "BB::BBoptim" ctrl.arg <- ", quiet=TRUE, control=optCtrl" } if (optimizer == "Rcgmin") { par.arg <- "par" optimizer <- "Rcgmin::Rcgmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "Rvmmin") { par.arg <- "par" optimizer <- "Rvmmin::Rvmmin" ctrl.arg <- ", control=optCtrl" } if (optimizer == "optimParallel") { par.arg <- "par" optimizer <- paste0("optimParallel::optimParallel") ctrl.arg <- ", control=optCtrl, parallel=parallel" parallel$cl <- NULL if (is.null(cl)) { ncpus <- as.integer(ncpus) if (ncpus < 1) stop(mstyle$stop("Control argument 'ncpus' must be >= 1.")) cl <- parallel::makePSOCKcluster(ncpus) on.exit(parallel::stopCluster(cl), add = TRUE) } else { if (!inherits(cl, "SOCKcluster")) stop(mstyle$stop("Specified cluster is not of class 'SOCKcluster'.")) } parallel$cl <- cl if (is.null(parallel$forward)) parallel$forward <- FALSE if (is.null(parallel$loginfo)) { if (verbose) { parallel$loginfo <- TRUE } else { parallel$loginfo <- FALSE } } } optcall <- paste(optimizer, "(", par.arg, "=c(coef(res.FE)[seq_len(p)], 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.FE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.FE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.FE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.FE$convergence != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.FE$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.FE$ierr != 0) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.FE$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.FE$status >= 1 && res.FE$status <= 4)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.FE$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.FE$convergence == 1 || res.FE$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit FE model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.FE$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.FE)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.FE$par <- res.FE$solution if (optimizer == "nlm") res.FE$par <- res.FE$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.FE <- numDeriv::hessian(.dnchg, x = res.FE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.FE <- pracma::hessian(.dnchg, x0 = res.FE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.FE <- -1 * res.FE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.FE <- -1 * res.FE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.FE <- -1 * res.FE$fval if (optimizer == "nlm") ll.FE <- -1 * res.FE$minimum if (QEconv) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) b.QE <- b.QE[!is.aliased] X.QE <- X.QE[, !is.aliased, drop = FALSE] optcall <- paste(optimizer, "(", par.arg, "=c(b.QE, 0),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.QE, random=FALSE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.QE <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.QE <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.QE$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.QE$convergence != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("dfoptim::mads")) && res.QE$convergence > optCtrl$tol) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.QE$ierr != 0) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.QE$ierr, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "nloptr::nloptr" && !(res.QE$status >= 1 && res.QE$status <= 4)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.QE$status, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (QEconv && optimizer == "ucminf::ucminf" && !(res.QE$convergence == 1 || res.QE$convergence == 2)) { warning(mstyle$warning(paste0("Cannot fit saturated model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.QE$convergence, ").")), call. = FALSE) QEconv <- FALSE ll.QE <- NA } if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.QE)) .print.output(tmp, mstyle$verbose) } if (QEconv && optimizer == "nloptr::nloptr") res.QE$par <- res.QE$solution if (QEconv && optimizer == "nlm") res.QE$par <- res.QE$estimate if (QEconv) { if (verbose > 1) message(mstyle$message("Computing Hessian ...")) if (con$hesspack == "numDeriv") h.QE <- numDeriv::hessian(.dnchg, x = res.QE$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) if (con$hesspack == "pracma") h.QE <- pracma::hessian(.dnchg, x0 = res.QE$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) } } else { res.QE <- res.FE h.QE <- h.FE } } if (k > 1 && QEconv) { if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.QE <- -1 * res.QE$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.QE <- -1 * res.QE$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.QE <- -1 * res.QE$fval if (optimizer == "nlm") ll.QE <- -1 * res.QE$minimum b2.QE <- res.QE$par hessian <- h.QE p.QE <- length(b2.QE) b2.QE <- b2.QE[-p.QE] hessian <- hessian[-p.QE, -p.QE, drop = FALSE] p.QE <- length(b2.QE) is.0 <- colSums(hessian == 0) == p.QE b2.QE <- b2.QE[!is.0] hessian <- hessian[!is.0, !is.0, drop = FALSE] b2.QE <- cbind(b2.QE[-seq_len(p)]) h.A <- hessian[seq_len(p), seq_len(p), drop = FALSE] h.B <- hessian[seq_len(p), -seq_len(p), drop = FALSE] h.C <- hessian[-seq_len(p), seq_len(p), drop = FALSE] h.D <- hessian[-seq_len(p), -seq_len(p), drop = FALSE] chol.h.A <- try(chol(h.A), silent = !verbose) if (inherits(chol.h.A, "try-error") || anyNA(chol.h.A)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { Ivb2.QE <- h.D - h.C %*% chol2inv(chol.h.A) %*% h.B QE.Wld <- c(t(b2.QE) %*% Ivb2.QE %*% b2.QE) } } } if (is.element(optimizer, c("clogit", "clogistic"))) { event <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(0, bi[i]), rep.int(1, ci[i]), rep.int(0, di[i])))) group1 <- unlist(lapply(seq_len(k), function(i) c(rep.int(1, ai[i]), rep.int(1, bi[i]), rep.int(0, ci[i]), rep.int(0, di[i])))) study.l <- factor(rep(seq_len(k), times = ni)) X.fit.l <- X[rep(seq_len(k), times = ni), , drop = FALSE] X.fit.l <- cbind(group1 * X.fit.l) const <- rep(1, length(event)) if (.isTRUE(ddd$retdat)) return(data.frame(event, group1, study.l, X.fit.l, const)) if (k > 1) { if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.fit.l + strata(study.l) res.FE <- try(do.call(clogit, args.clogit), silent = !verbose) } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.fit.l args.clogistic$strata <- study.l res.FE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } } else { stop(mstyle$stop(paste0("Cannot use '", optimizer, "' optimizer when k=1."))) } if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (QEconv) { if (verbose) message(mstyle$message("Fitting saturated model ...")) b.QE <- coef(res.QE, complete = TRUE) is.aliased <- is.na(b.QE) X.QE.l <- model.matrix(~-1 + X.fit.l + study.l:group1) X.QE.l <- X.QE.l[, !is.aliased, drop = FALSE] X.QE <- X.QE[, !is.aliased, drop = FALSE] if (optimizer == "clogit") { args.clogit <- clogitCtrl args.clogit$formula <- event ~ X.QE.l + strata(study.l) if (verbose) { res.QE <- try(do.call(clogit, args.clogit), silent = !verbose) } else { res.QE <- try(suppressWarnings(do.call(clogit, args.clogit)), silent = !verbose) } } if (optimizer == "clogistic") { args.clogistic <- clogisticCtrl args.clogistic$formula <- event ~ X.QE.l args.clogistic$strata <- study.l res.QE <- try(do.call(Epi::clogistic, args.clogistic), silent = !verbose) } if (inherits(res.QE, "try-error")) stop(mstyle$stop(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- -1 * .dnchg(c(cbind(coef(res.FE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) ll.QE <- -1 * .dnchg(c(cbind(coef(res.QE)), 0), ai = ai, bi = bi, ci = ci, di = di, X.fit = X.QE, random = FALSE, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec) b2.QE <- cbind(coef(res.QE)[-seq_len(p)]) vb2.QE <- vcov(res.QE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) optcall <- paste(optimizer, "(", par.arg, "=c(beta, log(tau2+.01)),\n .dnchg, ", ifelse(optimizer == "optim", "method=optmethod, ", ""), "ai=ai, bi=bi, ci=ci, di=di, X.fit=X.fit, random=TRUE,\n verbose=verbose, digits=digits,\n dnchgcalc=con$dnchgcalc, dnchgprec=con$dnchgprec, intCtrl=intCtrl", ctrl.arg, ")\n", sep = "") if (verbose) { res.ML <- try(eval(str2lang(optcall)), silent = !verbose) } else { res.ML <- try(suppressWarnings(eval(str2lang(optcall))), silent = !verbose) } if (optimizer == "optimParallel::optimParallel" && verbose) { tmp <- capture.output(print(res.ML$loginfo)) .print.output(tmp, mstyle$verbose) } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (is.element(optimizer, c("optim", "nlminb", "dfoptim::hjk", "dfoptim::nmk", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel")) && res.ML$convergence != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("dfoptim::mads")) && res.ML$convergence > optCtrl$tol) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa")) && res.ML$ierr != 0) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (ierr = ", res.ML$ierr, ")."))) if (optimizer == "nloptr::nloptr" && !(res.ML$status >= 1 && res.ML$status <= 4)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (status = ", res.ML$status, ")."))) if (optimizer == "ucminf::ucminf" && !(res.ML$convergence == 1 || res.ML$convergence == 2)) stop(mstyle$stop(paste0("Cannot fit ML model. Optimizer (", optimizer, ") did not achieve convergence (convergence = ", res.ML$convergence, ")."))) if (verbose > 2) { cat("\n") tmp <- capture.output(print(res.ML)) .print.output(tmp, mstyle$verbose) } if (optimizer == "nloptr::nloptr") res.ML$par <- res.ML$solution if (optimizer == "nlm") res.ML$par <- res.ML$estimate if (verbose > 1) message(mstyle$message("Computing Hessian ...")) tau2eff0 <- exp(res.ML$par[p + 1]) < con$tau2tol if (tau2eff0) method <- "T0" if (con$hesspack == "numDeriv") h.ML <- numDeriv::hessian(.dnchg, x = res.ML$par, method.args = hessianCtrl, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (con$hesspack == "pracma") h.ML <- pracma::hessian(.dnchg, x0 = res.ML$par, ai = ai, bi = bi, ci = ci, di = di, X.fit = X.fit, random = !tau2eff0, verbose = verbose, digits = digits, dnchgcalc = con$dnchgcalc, dnchgprec = con$dnchgprec, intCtrl = intCtrl) if (is.element(optimizer, c("optim", "dfoptim::hjk", "dfoptim::nmk", "dfoptim::mads", "ucminf::ucminf", "lbfgsb3c::lbfgsb3c", "subplex::subplex", "BB::BBoptim", "Rcgmin::Rcgmin", "Rvmmin:Rvmmin", "optimParallel::optimParallel"))) ll.ML <- -1 * res.ML$value if (is.element(optimizer, c("nlminb", "nloptr::nloptr"))) ll.ML <- -1 * res.ML$objective if (is.element(optimizer, c("minqa::uobyqa", "minqa::newuoa", "minqa::bobyqa"))) ll.ML <- -1 * res.ML$fval if (optimizer == "nlm") ll.ML <- -1 * res.ML$minimum } if (is.element(method, c("FE", "EE", "CE", "T0"))) { if (!is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(res.FE$par[seq_len(p)]) chol.h <- try(chol(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb <- try(qr.solve(h.FE[seq_len(p), seq_len(p)]), silent = !verbose) if (inherits(vb, "try-error")) stop(mstyle$stop(paste0("Cannot invert Hessian for the ", ifelse(method == "T0", "ML", method), " model."))) } else { vb <- chol2inv(chol.h) } } if (is.element(optimizer, c("clogit", "clogistic"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] } tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { beta <- cbind(res.ML$par[seq_len(p)]) chol.h <- try(chol(h.ML), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { if (anyNA(chol.h)) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) warning(mstyle$warning("Choleski factorization of Hessian failed. Trying inversion via QR decomposition."), call. = FALSE) vb.f <- try(qr.solve(h.ML), silent = !verbose) if (inherits(vb.f, "try-error")) stop(mstyle$stop("Cannot invert Hessian for the ML model.")) } else { vb.f <- chol2inv(chol.h) } vb <- vb.f[seq_len(p), seq_len(p), drop = FALSE] if (any(diag(vb) <= 0)) stop(mstyle$stop("Cannot compute var-cov matrix of the fixed effects.")) tau2 <- exp(res.ML$par[p + 1]) sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k if (vb.f[p + 1, p + 1] >= 0) { se.tau2 <- sqrt(vb.f[p + 1, p + 1]) * tau2 crit <- qnorm(level/2, lower.tail = FALSE) ci.lb.tau2 <- exp(res.ML$par[p + 1] - crit * sqrt(vb.f[p + 1, p + 1])) ci.ub.tau2 <- exp(res.ML$par[p + 1] + crit * sqrt(vb.f[p + 1, p + 1])) } } if (is.element(method, c("ML", "T0"))) { tmp <- try(rma.uni(measure = "PETO", ai = ai, bi = bi, ci = ci, di = di, add = 0, mods = X.fit, intercept = FALSE, skipr2 = TRUE), silent = TRUE) if (!inherits(tmp, "try-error")) { gvar1 <- det(vcov(tmp)) gvar2 <- det(vb) ratio <- (gvar1/gvar2)^(1/(2 * m)) if (!is.na(ratio) && ratio >= 100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually small. Treat results with caution."), call. = FALSE) se.warn <- TRUE } if (!is.na(ratio) && ratio <= 1/100) { warning(mstyle$warning("Standard errors of fixed effects appear to be unusually large. Treat results with caution."), call. = FALSE) se.warn <- TRUE } } } if (method == "T0") { tau2 <- exp(res.ML$par[p + 1]) parms <- p + 1 se.tau2 <- 0 method <- "ML" } } } if (is.element(measure, c("PLO", "PR", "PLN", "IRLN"))) { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.grp <- cbind(xi = xi, mi = mi) if (is.null(ddd$family)) { if (measure == "PLO") dat.fam <- binomial(link = link) if (measure == "PR") dat.fam <- binomial(link = link) if (measure == "PLN") dat.fam <- binomial(link = link) } else { dat.fam <- ddd$family } dat.off <- NULL } if (is.element(measure, c("IRLN"))) { dat.grp <- xi if (is.null(ddd$family)) { dat.fam <- poisson(link = link) } else { dat.fam <- ddd$family } dat.off <- log(ti) } study <- factor(seq_len(k)) X.fit <- X if (.isTRUE(ddd$retdat)) return(list(dat.grp = dat.grp, X.fit = X.fit, study = study, dat.off = if (!is.null(dat.off)) dat.off else NULL, dat.fam = dat.fam)) if (verbose) message(mstyle$message("Fitting FE model ...")) res.FE <- try(glm(dat.grp ~ -1 + X.fit, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) if (inherits(res.FE, "try-error")) stop(mstyle$stop(paste0("Cannot fit FE model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) ll.FE <- c(logLik(res.FE)) QEconv <- FALSE ll.QE <- NA if (!isTRUE(ddd$skiphet)) { if (k > 1 && verbose) message(mstyle$message("Fitting saturated model ...")) if (k > 1) { X.QE <- model.matrix(~-1 + X.fit + study) if (verbose) { res.QE <- try(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl), silent = !verbose) } else { res.QE <- try(suppressWarnings(glm(dat.grp ~ -1 + X.QE, offset = dat.off, family = dat.fam, control = glmCtrl)), silent = !verbose) } } else { res.QE <- res.FE } if (inherits(res.QE, "try-error")) { warning(mstyle$warning(paste0("Cannot fit saturated model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details)."))), call. = FALSE) } else { QEconv <- TRUE ll.QE <- c(logLik(res.QE)) b2.QE <- cbind(coef(res.QE, complete = FALSE)[-seq_len(p)]) vb2.QE <- vcov(res.QE, complete = FALSE)[-seq_len(p), -seq_len(p), drop = FALSE] } } if (method == "ML") { if (verbose) message(mstyle$message("Fitting ML model ...")) if (package == "lme4") { if (verbose) { res.ML <- try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(lme4::glmer(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = do.call(lme4::glmerControl, glmerCtrl)), silent = !verbose)) } } if (package == "GLMMadaptive") { if (is.element(measure, c("PLO", "PR", "PLN"))) { dat.mm <- data.frame(xi = dat.grp[, "xi"], mi = dat.grp[, "mi"], study = study) res.ML <- try(GLMMadaptive::mixed_model(cbind(xi, mi) ~ -1 + X.fit, random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } else { dat.mm <- data.frame(xi = dat.grp, study = study) res.ML <- try(GLMMadaptive::mixed_model(xi ~ -1 + X.fit + offset(dat.off), random = ~1 | study, data = dat.mm, family = dat.fam, nAGQ = nAGQ, verbose = verbose, control = glmerCtrl), silent = !verbose) } } if (package == "glmmTMB") { if (verbose) { res.ML <- try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose) } else { res.ML <- suppressMessages(try(glmmTMB::glmmTMB(dat.grp ~ -1 + X.fit + (1 | study), offset = dat.off, family = dat.fam, verbose = verbose, data = NULL, control = do.call(glmmTMB::glmmTMBControl, glmerCtrl)), silent = !verbose)) } } if (inherits(res.ML, "try-error")) stop(mstyle$stop(paste0("Cannot fit ML model", ifelse(verbose, ".", " (set 'verbose=TRUE' to obtain further details).")))) if (package == "lme4") { ll.ML <- ll.QE - 1/2 * deviance(res.ML) } else { ll.ML <- c(logLik(res.ML)) } } if (is.element(method, c("FE", "EE", "CE"))) { beta <- cbind(coef(res.FE)[seq_len(p)]) vb <- vcov(res.FE)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- 0 sigma2 <- NA parms <- p p.eff <- p k.eff <- k } if (method == "ML") { if (package == "lme4") { beta <- cbind(lme4::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- lme4::VarCorr(res.ML)[[1]][1] } if (package == "GLMMadaptive") { beta <- cbind(GLMMadaptive::fixef(res.ML)[seq_len(p)]) vb <- as.matrix(vcov(res.ML))[seq_len(p), seq_len(p), drop = FALSE] tau2 <- res.ML$D[1, 1] } if (package == "glmmTMB") { beta <- cbind(glmmTMB::fixef(res.ML)$cond[seq_len(p)]) vb <- as.matrix(vcov(res.ML)$cond)[seq_len(p), seq_len(p), drop = FALSE] tau2 <- glmmTMB::VarCorr(res.ML)[[1]][[1]][[1]] } sigma2 <- NA parms <- p + 1 p.eff <- p k.eff <- k } } if (verbose > 1) message(mstyle$message("Conducting heterogeneity tests ...")) if (k > 1 && QEconv) { if (!(measure == "OR" && model == "CM.EL" && !is.element(optimizer, c("clogit", "clogistic")))) { if (nrow(vb2.QE) > 0) { chol.h <- try(chol(vb2.QE), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } else { QE.Wld <- try(c(t(b2.QE) %*% chol2inv(chol.h) %*% b2.QE), silent = !verbose) if (inherits(QE.Wld, "try-error")) { warning(mstyle$warning("Cannot invert Hessian for saturated model."), call. = FALSE) QE.Wld <- NA } } } else { QE.Wld <- 0 } } QE.LRT <- -2 * (ll.FE - ll.QE) QE.Wld[QE.Wld <= 0] <- 0 QE.LRT[QE.LRT <= 0] <- 0 QE.df <- k - p if (QE.df > 0) { QEp.Wld <- pchisq(QE.Wld, df = QE.df, lower.tail = FALSE) QEp.LRT <- pchisq(QE.LRT, df = QE.df, lower.tail = FALSE) } else { QEp.Wld <- 1 QEp.LRT <- 1 } } else { QE.Wld <- NA QE.LRT <- NA QEp.Wld <- NA QEp.LRT <- NA QE.df <- NA } wi <- 1/vi W <- diag(wi, nrow = k.yi, ncol = k.yi) stXWX <- .invcalc(X = X.yi, W = W, k = k.yi) P <- W - W %*% X.yi %*% stXWX %*% crossprod(X.yi, W) if (i2def == "1") vt <- (k.yi - p)/.tr(P) if (i2def == "2") vt <- 1/mean(wi) I2 <- 100 * tau2/(vt + tau2) H2 <- tau2/vt + 1 if (verbose > 1) message(mstyle$message("Conducting tests of the fixed effects ...")) chol.h <- try(chol(vb[btt, btt]), silent = !verbose) if (inherits(chol.h, "try-error") || anyNA(chol.h)) { warning(mstyle$warning("Cannot invert Hessian for QM test."), call. = FALSE) QM <- NA } else { QM <- as.vector(t(beta)[btt] %*% chol2inv(chol.h) %*% beta[btt]) } if (!int.only && int.incl && con$scaleX) { mX <- rbind(c(intrcpt = 1, -1 * ifelse(is.d[-1], 0, meanX/sdX)), cbind(0, diag(ifelse(is.d[-1], 1, 1/sdX), nrow = length(is.d) - 1, ncol = length(is.d) - 1))) beta <- mX %*% beta vb <- mX %*% vb %*% t(mX) X <- Xsave } if (test == "t") { ddf <- k - p } else { ddf <- NA } if (.isTRUE(ddd$abbrev)) { tmp <- colnames(X) tmp <- gsub("relevel(factor(", "", tmp, fixed = TRUE) tmp <- gsub("\\), ref = \"[[:alnum:]]*\")", "", tmp) tmp <- gsub("poly(", "", tmp, fixed = TRUE) tmp <- gsub(", degree = [[:digit:]], raw = TRUE)", "^", tmp) tmp <- gsub(", degree = [[:digit:]], raw = T)", "^", tmp) tmp <- gsub(", degree = [[:digit:]])", "^", tmp) tmp <- gsub("rcs\\([[:alnum:]]*, [[:digit:]]\\)", "", tmp) tmp <- gsub("factor(", "", tmp, fixed = TRUE) tmp <- gsub("I(", "", tmp, fixed = TRUE) tmp <- gsub(")", "", tmp, fixed = TRUE) colnames(X) <- tmp } rownames(beta) <- rownames(vb) <- colnames(vb) <- colnames(X.f) <- colnames(X) ve <- diag(vb) se <- ifelse(ve >= 0, sqrt(ve), NA) names(se) <- NULL zval <- c(beta/se) if (test == "t") { QM <- QM/m QMdf <- c(m, k - p) QMp <- if (QMdf[2] > 0) pf(QM, df1 = QMdf[1], df2 = QMdf[2], lower.tail = FALSE) else NA pval <- if (ddf > 0) 2 * pt(abs(zval), df = ddf, lower.tail = FALSE) else rep(NA, p) crit <- if (ddf > 0) qt(level/2, df = ddf, lower.tail = FALSE) else rep(NA, p) } else { QMdf <- c(m, NA) QMp <- pchisq(QM, df = QMdf[1], lower.tail = FALSE) pval <- 2 * pnorm(abs(zval), lower.tail = FALSE) crit <- qnorm(level/2, lower.tail = FALSE) } ci.lb <- c(beta - crit * se) ci.ub <- c(beta + crit * se) if (verbose > 1) message(mstyle$message("Computing fit statistics and log likelihood ...")) ll.ML <- ifelse(is.element(method, c("FE", "EE", "CE")), ll.FE, ll.ML) ll.REML <- NA dev.ML <- -2 * (ll.ML - ll.QE) AIC.ML <- -2 * ll.ML + 2 * parms BIC.ML <- -2 * ll.ML + parms * log(k.eff) AICc.ML <- -2 * ll.ML + 2 * parms * max(k.eff, parms + 2)/(max(k.eff, parms + 2) - parms - 1) dev.REML <- NA AIC.REML <- NA BIC.REML <- NA AICc.REML <- NA fit.stats <- matrix(c(ll.ML, dev.ML, AIC.ML, BIC.ML, AICc.ML, ll.REML, dev.REML, AIC.REML, BIC.REML, AICc.REML), ncol = 2, byrow = FALSE) dimnames(fit.stats) <- list(c("ll", "dev", "AIC", "BIC", "AICc"), c("ML", "REML")) fit.stats <- data.frame(fit.stats) if (verbose > 1) message(mstyle$message("Preparing output ...")) weighted <- TRUE if (is.null(ddd$outlist) || ddd$outlist == "nodata") { outdat <- list(ai = ai, bi = bi, ci = ci, di = di, x1i = x1i, x2i = x2i, t1i = t1i, t2i = t2i, xi = xi, mi = mi, ti = ti) res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, rho = rho, ci.lb.tau2 = ci.lb.tau2, ci.ub.tau2 = ci.ub.tau2, I2 = I2, H2 = H2, vt = vt, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.f = k.f, k.yi = k.yi, k.eff = k.eff, k.all = k.all, p = p, p.eff = p.eff, parms = parms, int.only = int.only, int.incl = int.incl, intercept = intercept, yi = yi, vi = vi, X = X, yi.f = yi.f, vi.f = vi.f, X.f = X.f, outdat.f = outdat.f, outdat = outdat, ni = ni, ni.f = ni.f, ids = ids, not.na = not.na, subset = subset, not.na.yivi = not.na.yivi, slab = slab, slab.null = slab.null, measure = measure, method = method, model = model, weighted = weighted, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, level = level, control = control, verbose = verbose, add = add, to = to, drop00 = drop00, fit.stats = fit.stats, se.warn = se.warn, formula.yi = NULL, formula.mods = formula.mods, version = packageVersion("metafor"), call = mf) if (is.null(ddd$outlist)) res <- append(res, list(data = data), which(names(res) == "fit.stats")) } else { if (ddd$outlist == "minimal") { res <- list(b = beta, beta = beta, se = se, zval = zval, pval = pval, ci.lb = ci.lb, ci.ub = ci.ub, vb = vb, tau2 = tau2, se.tau2 = se.tau2, sigma2 = sigma2, I2 = I2, H2 = H2, QE.Wld = QE.Wld, QEp.Wld = QEp.Wld, QE.LRT = QE.LRT, QEp.LRT = QEp.LRT, QE.df = QE.df, QEp = QEp, QM = QM, QMdf = QMdf, QMp = QMp, k = k, k.eff = k.eff, p = p, p.eff = p.eff, parms = parms, int.only = int.only, measure = measure, method = method, model = model, test = test, dfs = ddf, ddf = ddf, btt = btt, m = m, digits = digits, fit.stats = fit.stats) } else { res <- eval(str2lang(paste0("list(", ddd$outlist, ")"))) } } if (.isTRUE(ddd$retfit)) { res$res.FE <- res.FE if (!isTRUE(ddd$skiphet)) res$res.QE <- res.QE if (method == "ML") res$res.ML <- res.ML } time.end <- proc.time() res$time <- unname(time.end - time.start)[3] if (.isTRUE(ddd$time)) .print.time(res$time) if (verbose || .isTRUE(ddd$time)) cat("\n") class(res) <- c("rma.glmm", "rma") return(res) })(ai = c(2, 65, 102, 52, 92, 25, 33, 6, 0, 0, 84), ci = c(2, 69, 169, 169, 169, 186, 186, 5583, 120, 635, 256), n1i = c(30, 88, 623, 331, 584, 134, 108, 10, 12, 11, 184), n2i = c(80, 87, 1538, 1538, 1538, 864, 864, 16005, 5468, 6090, 695), measure = "OR", model = "UM.FS", method = "ML", test = "z", level = 95, control = list(NULL)), time = 0.338000000000079), 4.2-0, UM.FS

Final table

Final table
N	N_stu	study	rl_sm	group1	group2	pL_creative	pL_control	lower	effect	upper	p	I2	comparison	model_type	label	es_type	se
Architecture
7	7							0.813	0.966	1.148	.70	.00 [.00, .71]		random (all)	glmer	OR
		shettel-neuber_1983	S/M	Architecture	Law, Psychology	0/23 (0%)	2/55 (3.64%)	0	0	4.737	.89		(SR+SL)/M			OR	1.208
		nlsy79	S/M	Architects, except naval	Non-art, architecture, music	0/9 (0%)	120/5468 (2.19%)	0	0	19.165	1.00		(SR+SL)/M			OR	4.889
		nlsy97	S/M	Architects, except naval	Non-art, architecture, music	0/4 (0%)	635/6090 (10.43%)	0	0	8.271	1.00		(SR+SL)/M			OR	2.11
		gotestam_1990	S/M	Architecture (freshmen)	HS seniors	45/60 (75%)	69/87 (79.31%)	0.36	0.783	1.699	.68		(SR+SL)/M			OR	0.341
		cosenza_1993	S/M	Architecture applicants	Non-art/music/ architecture applicants	179/526 (34.03%)	5583/16005 (34.88%)	0.802	0.963	1.157	.72		(SR+SL)/M			OR	0.091
		schacter_1996	S/M	Architects	Non-architects	7/148 (4.73%)	41/1048 (3.91%)	0.547	1.219	2.719	.80		(SR+SL)/M			OR	0.554
		wood_1991	S/M	Architecture students (W)	General students (W)	2/27 (7.41%)	2/149 (1.34%)	0.985	5.88	35.164	.21		(SR+SL)/M			OR	8.719
Art
8	8							1.498	1.836	2.25	<.001	.71 [.40, .86]		random (all)	glmer	OR
		shettel-neuber_1983	S/M	Art	Law, Psychology	1/31 (3.23%)	2/55 (3.64%)	0.111	0.883	7.173	1.00		(SR+SL)/M			OR	1.802
		nlsy79	S/M	Artistic occupations	Non-art, architecture, music	1/43 (2.33%)	120/5468 (2.19%)	0.183	1.061	6.164	1.00		(SR+SL)/M			OR	1.526
		nlsy97	S/M	Artistic occupations	Non-art, architecture, music	9/78 (11.54%)	636/6091 (10.44%)	0.563	1.119	2.224	.90		(SR+SL)/M			OR	0.424
		cosenza_1993	S/M	Fine Arts applicants	Non-art/music/ architecture applicants	20/51 (39.22%)	5583/16005 (34.88%)	0.691	1.204	2.1	.62		(SR+SL)/M			OR	0.36
		giotakos_2004	S/M	Art Hobbies	Non-Art Hobbies	84/184 (45.65%)	256/695 (36.83%)	1.037	1.44	2	.04		(SR+SL)/M			OR	0.246
		mebert_1980	S/M	Art	Non-Art	28/103 (27.18%)	15/101 (14.85%)	1.069	2.14	4.28	.05		(SR+SL)/M			OR	0.819
		coren_1982	S/M	Science/Visual Art	Lang/Lit	69/225 (30.67%)	21/262 (8.02%)	3.002	5.076	8.582	<.001		SR/(M+SL)			OR	1.423
		preti_2007	S/M	Writers, Painters	Noncreatives	8/50 (16%)	2/80 (2.5%)	1.68	7.429	32.361	.01		(SR+SL)/M			OR	7.827
Music
11	8							1.246	1.417	1.612	<.001	.10 [.00, .50]		random (all)	glmer	OR
		nlsy79	S/M	Musicians and composers	Non-art, architecture, music	0/12 (0%)	120/5468 (2.19%)	0	0	14.357	1.00		(SR+SL)/M			OR	3.663
		nlsy97	S/M	Musicians, singers and related workers	Non-art, architecture, music	0/11 (0%)	635/6090 (10.43%)	0	0	3.005	.52		(SR+SL)/M			OR	0.767
		gotestam_1990	S/M	Music (freshmen)	HS seniors	65/88 (73.86%)	69/87 (79.31%)	0.366	0.737	1.485	.50		(SR+SL)/M			OR	0.285
		byrne_1974	S/M	Singers	General students	25/134 (18.66%)	186/864 (21.53%)	0.527	0.836	1.326	.52		(SR+SL)/M			OR	0.204
		giotakos_2004	S/M	Art Hobbies	Non-Art Hobbies	84/184 (45.65%)	256/695 (36.83%)	1.037	1.44	2	.04		(SR+SL)/M			OR	0.246
		aggleton_1994	S/M	Composers	British adults	52/331 (15.71%)	169/1538 (10.99%)	1.079	1.51	2.113	.02		(SR+SL)/(ML+MR)			OR	0.264
		aggleton_1994	S/M	Choir Members	British adults	92/584 (15.75%)	169/1538 (10.99%)	1.151	1.515	1.993	.004		(SR+SL)/(ML+MR)			OR	0.215
		aggleton_1994	S/M	Instrumental musicians	British adults	102/623 (16.37%)	169/1538 (10.99%)	1.216	1.586	2.068	<.001		(SR+SL)/(ML+MR)			OR	0.217
		byrne_1974	S/M	Instrumental musicians	General students	33/108 (30.56%)	186/864 (21.53%)	1.035	1.604	2.488	.05		(SR+SL)/M			OR	0.371
		preti_2007	S/M	Musicians	Noncreatives	2/30 (6.67%)	2/80 (2.5%)	0.464	2.786	16.726	.64		(SR+SL)/M			OR	4.148
		cosenza_1993	S/M	Music applicants	Non-art/music/ architecture applicants	6/10 (60%)	5583/16005 (34.88%)	0.849	2.8	9.239	.18		(SR+SL)/M			OR	2.14

Blank (collapse)